求将固定位置的图片插入Powerpoint的代码
要求：1、将固定文件夹的所有图片插入到Powerpoint中
2、每面插入一张图片
3、插入完成后自动保存
4、完成后自动保存Powerpoint
求将固定位置的图片插入Powerpoint的代码
要求：1、将固定文件夹的所有图片插入到Powerpoint中
2、每面插入一张图片
3、插入完成后自动保存
4、完成后自动保存Powerpoint
求将固定位置的图片插入Powerpoint的代码
要求：1、将固定文件夹的所有图片插入到Powerpoint中
2、每面插入一张图片
3、插入完成后自动保存
4、完成后自动保存Powerpoint
用Presentations.open打开一个PPT文件，操作完成后再用Presentation.save进行保存。其他的你自己研究吧！
不过估计和将数据导出到excel差不多吧。
需要用到office组件。
关注中……
'看看这段。
'FileA----- FileListBox
Dim i As Integer, picPath As String
Dim PPA As PowerPoint.Application
Set PPA = New PowerPoint.Application
PPA .Presentations.Add(msoTrue)
For i = 0 To FileA.ListCount - 1
If Right(FileA.Path, 1) = "\" Then
picPath = FileA.Path & FileA.List(i)
Else
picPath = FileA.Path & "\" & FileA.List(i)
End If
With PPA
.ActivePresentation.Slides.Add i + 1, ppLayoutBlank
.ActiveWindow.View.GotoSlide i + 1
.ActiveWindow.Selection.SlideRange.Shapes.AddPicture picPath, msoFalse, msoTrue, 0, 0
End With
Next
PPA.ActivePresentation.SaveAs "e:\temp.ppt"
然后学习一下宏的代码，
移植到VB中即可。
请到http://download.csdn.net/source/528209下载例子源码
老大：
这个程序运行不了呀，提示“实时错误 对象‘add’的方法‘Presentations’失败
http://download.csdn.net/source/528504已测试通过
http://download.csdn.net/source/528504 已测试通过
----------------------------------------------
还是一样的问题
有问题
你是不是装了kab 6.0杀毒软件，如果是,应该是被Kab拦截了，请在Kab设定中将巨集中相应一些项停掉。以上两个程序源码我都测试过没有问题。
Imports Microsoft.Office.Core
Public Class Form1 Dim objPPT As PowerPoint.Application
Dim objPres As PowerPoint.Presentation Private Sub cmdStart_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdStart.Click
StartPowerPoint()
End Sub
Private Sub cmdCreatePresentation_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdCreatePresentation.Click
EnsurePowerPointIsRunning(False, False)
'添加演示文稿
objPres = objPPT.Presentations.Add(MsoTriState.msoTrue)
End Sub
Private Sub cmdAddSlide_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdAddSlide.Click
Dim objSlide As PowerPoint.Slide
Dim objCustomLayout As PowerPoint.CustomLayout
EnsurePowerPointIsRunning(True)
'基于幻灯片母版中的第一个布局创建自定义布局。
'这只是用于创建幻灯片
objCustomLayout = objPres.SlideMaster.CustomLayouts.Item(1)
'创建幻灯片
objSlide = objPres.Slides.AddSlide(1, objCustomLayout)
'设置布局
objSlide.Layout = PowerPoint.PpSlideLayout.ppLayoutText
'清理
objCustomLayout.Delete()
objCustomLayout = Nothing
objSlide = Nothing
End Sub
Private Sub cmdRemoveSlide_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdRemoveSlide.Click
EnsurePowerPointIsRunning(True)
If objPres.Slides.Count > 0 Then
objPres.Slides(1).Delete()
Else
MsgBox("No slides to remove", MsgBoxStyle.Information)
End If
End Sub
Private Sub cmdSetTitleText_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdSetTitleText.Click
Dim i As Integer
EnsurePowerPointIsRunning(True, True)
'向幻灯片标题中添加文本。查找形状集合中的第一个文本框
'如果不存在文本框，则不执行任何操作
objPres.Slides(1).Select()
For i = 1 To objPres.Slides(1).Shapes.Count
If objPres.Slides(1).Shapes(i).HasTextFrame Then
objPres.Slides(1).Shapes(i).TextFrame.TextRange.Text = Me.txtTitle.Text
Exit For
End If
Next i
End Sub
Private Sub cmdAddChart_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdAddChart.Click
Dim ds As New ShipmentSchema, dt As ShipmentSchema.ShipmentDataTable
EnsurePowerPointIsRunning(True, True)
'
'从随此示例分发的 XML 文件中
'加载数据
ds.ReadXml(My.Application.Info.DirectoryPath & "\ShipmentData.xml")
dt = ds.Tables("Shipment")
'
'启动 Excel，用 XML 数据填充工作表，在 Excel 中创建图表
'然后复制到 Powerpoint 中
Dim objExcel As Excel.Application
Dim objWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim objChart As Excel.Chart
objExcel = New Excel.Application
objExcel.Visible = True
objWorkbook = objExcel.Workbooks.Add
objSheet = objWorkbook.Sheets("Sheet1")
DataTableToExcelSheet(dt, objSheet, 1, 1)
objSheet.Range("A1:B4").Select()
objChart = objExcel.Charts.Add()
With objChart
'3D 饼图
.ChartType = Excel.XlChartType.xl3DPie
'图表样式为数值样式 - 通过将光标悬停在 Excel 中的图表样式库上，
'可找到图表样式列表
.ChartStyle = 10
'关闭自动缩放可以允许用户自行调整图表的大小
.AutoScaling = False
'增大仰角会使饼图向用户倾斜
.Elevation = 30
.Select()
End With
Application.DoEvents()
'宽度和高度的设置均以像素为单位
objExcel.Selection.width = 300
objExcel.Selection.Height = 300
'将图表的图片复制到剪贴板
objChart.CopyPicture(Excel.XlPictureAppearance.xlPrinter, Excel.XlCopyPictureFormat.xlPicture, Excel.XlPictureAppearance.xlPrinter)
'粘贴到 PowerPoint 中
objPPT.Activate()
Dim objSlide As PowerPoint.Slide
Dim objShape As PowerPoint.Shape
objSlide = objPres.Slides(1)
objSlide.Select()
objSlide.Layout = PowerPoint.PpSlideLayout.ppLayoutTitleOnly
objSlide.Shapes.Paste()
objShape = objSlide.Shapes(2)
objShape.ZOrder(MsoZOrderCmd.msoSendToBack)
objShape.Left = 400
objShape.Top = 100
'清理
objWorkbook.Close(False)
objExcel.Quit()
objExcel = Nothing
End Sub
Dim objShape As PowerPoint.Shape
Dim objTable As PowerPoint.Table
EnsurePowerPointIsRunning(True, True)
'
'从随示例应用程序分发的 XML 文件中加载
'数据表。将用此表填充
'PowerPoint 表
Dim ds As New ShipmentSchema, dt As ShipmentSchema.ShipmentDataTable
ds.ReadXml(My.Application.Info.DirectoryPath & "\ShipmentData.xml")
dt = ds.Tables("Shipment")
'
'向演示文稿内的第一个幻灯片中添加表
objPres.Slides(1).Select()
objShape = objPres.Slides(1).Shapes.AddTable(5, 2, 50, 100, 300)
objTable = objShape.Table
'
'用数据集中的数据填充表
With objShape.Table
.Cell(1, 1).Shape.TextFrame.TextRange.Text = dt.Columns.Item(0).ColumnName
.Cell(1, 2).Shape.TextFrame.TextRange.Text = dt.Columns.Item(1).ColumnName
'用样式的 GUID 应用表样式
.ApplyStyle("{B301B821-A1FF-4177-AEE7-76D212191A09}", False)
Dim nRow As Integer, nCol As Integer
For nRow = 0 To dt.Rows.Count - 1
For nCol = 0 To dt.Columns.Count - 1
.Cell(2 + nRow, 1 + nCol).Shape.TextFrame.TextRange.Text = dt.Rows(nRow).Item(nCol)
Next nCol
Next nRow
End With
'
'清理
objTable = Nothing
objShape = Nothing
dt = Nothing
ds = Nothing
End Sub
Private Sub cmdAddTextbox_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdAddTextbox.Click
Dim objShape As PowerPoint.Shape
Dim strText As String = "Tacoma shipments increase 10%" & vbCrLf & "Seattle shipments steady"
EnsurePowerPointIsRunning(True, True)
objPres.Slides(1).Select()
objShape = objPres.Slides(1).Shapes.AddTextbox(MsoTextOrientation.msoTextOrientationHorizontal, 50, 300, 300, 300)
objShape.TextFrame.AutoSize = PowerPoint.PpAutoSize.ppAutoSizeShapeToFitText
objShape.TextFrame.TextRange.Text = strText
objShape.TextEffect.FontSize = 20
objShape.TextEffect.FontBold = MsoTriState.msoTrue
'
'清理
objShape = Nothing
End Sub
Sub StartPowerPoint()
objPPT = New PowerPoint.Application
objPPT.Visible = MsoTriState.msoTrue
objPPT.WindowState = PowerPoint.PpWindowState.ppWindowMaximized
End Sub
Sub EnsurePowerPointIsRunning(Optional ByVal blnAddPresentation As Boolean = False, Optional ByVal blnAddSlide As Boolean = False)
Dim strName As String
'
'尝试访问名称属性。如果这会引起异常，
'则启动新的 PowerPoint 实例
Try
strName = objPPT.Name
Catch ex As Exception
StartPowerPoint()
End Try
'
'blnAddPresentation 用于确保已加载演示文稿
If blnAddPresentation = True Then
Try
strName = objPres.Name
Catch ex As Exception
objPres = objPPT.Presentations.Add(MsoTriState.msoTrue)
End Try
End If
'
'BlnAddSlide 用于确保演示文稿中至少有一个
'幻灯片
If blnAddSlide Then
Try
strName = objPres.Slides(1).Name
Catch ex As Exception
Dim objSlide As PowerPoint.Slide
Dim objCustomLayout As PowerPoint.CustomLayout
objCustomLayout = objPres.SlideMaster.CustomLayouts.Item(1)
objSlide = objPres.Slides.AddSlide(1, objCustomLayout)
objSlide.Layout = PowerPoint.PpSlideLayout.ppLayoutText
objCustomLayout = Nothing
objSlide = Nothing
End Try
End If
End Sub
Private Sub cmdQuit_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdQuit.Click
Try
objPres.Close()
objPres = Nothing
Catch
End Try
Try
objPPT.Quit()
objPPT = Nothing
Catch ex As Exception
End Try
System.GC.Collect()
End Sub
Sub DataTableToExcelSheet(ByVal dt As DataTable, ByVal objSheet As Excel.Worksheet, ByVal nStartRow As Integer, ByVal nStartCol As Integer)
Dim nRow As Integer, nCol As Integer
'将数据表复制到 Excel 工作表中
For nRow = 0 To dt.Rows.Count - 1
For nCol = 0 To dt.Columns.Count - 1
objSheet.Cells(nStartRow + nRow, nStartCol + nCol) = dt.Rows(nRow).Item(nCol)
Next nCol
Next nRow
End Sub
End Class
你的这个根本就不通嘛
你的程序在VB里的红色（就是不通嘛）
Dim f As String, i As Long
With CreateObject("PowerPoint.Application")
.Visible = True
.Presentations.Add -1
.ActivePresentation.SaveAs "d:\temp.ppt"
f = Dir("D:\*.GIF")
While f > ""
i = i + 1
.ActivePresentation.Slides.Add i, 12
.ActiveWindow.View.GotoSlide i
.ActiveWindow.Selection.SlideRange.Shapes.AddPicture "d:\" & f, 0, -1, 0, 0
.ActivePresentation.Save
f = Dir
Wend End With
MsgBox "ok"
End Sub
但不知道怎么才能把图片大小改为和幻灯片一样大？
Dim f As String, i As Long
With CreateObject("PowerPoint.Application")
.Visible = True
.Presentations.Add -1
.ActivePresentation.SaveAs "d:\temp.ppt"
f = Dir("D:\*.GIF")
While f > ""
i = i + 1
.ActivePresentation.Slides.Add i, 12
.ActiveWindow.View.GotoSlide i
.ActiveWindow.Selection.SlideRange.Shapes.AddPicture "d:\" & f, 0, -1, 0, 0, Application.Width * 0.93, Application.Height * 0.97
.ActivePresentation.Save
f = Dir
Wend
End With
MsgBox "ok"
End Sub
Sub Addpicstopowerpoint()
Dim f As String, i As Long
With CreateObject("PowerPoint.Application")
.Visible = True
.Presentations.Add -1
.ActivePresentation.SaveAs "d:\temp.ppt"
f = Dir("D:\*.GIF")
While f > ""
i = i + 1
.ActivePresentation.Slides.Add i, 12
.ActiveWindow.View.GotoSlide i
.ActiveWindow.Selection.SlideRange.Shapes.AddPicture "d:\" & f, 0, -1, 0, 0, Application.Width * 0.93, Application.Height * 0.97
.ActivePresentation.Save
f = Dir
Wend
End With
MsgBox "ok"
End Sub
1.Microsoft PowerPoint 9.0 Object Library
2.Microsoft Office 9.0 Object Library