如何在Powerpoint中使用VBA添加图像到特定的命名占位符
我一直想弄清楚这个问题。我已经复制了下面所有的代码。我想做的是，我在ppt上添加了3张图片，格式是我提供的。我遇到的问题是，当没有找到图像时(我已经告诉系统恢复)，下一个图像出现在前一个占位符中。不是我想要的那个。PowerPoint是打开的，正如你所看到的，我甚至尝试选择占位符，看看这是否有区别。如果没有办法解决这个问题。谁能建议如何捕获图像没有填充，所以我可以填充一个图像，说"图像不可用"只是为了保持一切在正确的地方?
在下面搜索:如果oPPtShp.PlaceholderFormat.Type = ppPlaceholderPicture Then以找到我加载图像的IF开头。
请帮忙!
Sub AddPPT2010()
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:Program Files (x86)Microsoft OfficeOffice14MSPPT.OLB"
Const imgFileName = "PrintIcon"
Const GUIDRef = "{91493440-5A91-11CF-8700-00AA0060263B}"
Set PrntIcon = Application.CommandBars.FindControl(ID:=4)
On Error Resume Next 'Ignore Error If Reference Already Established
ThisWorkbook.VBProject.References.AddFromGuid GUIDRef, 2, 10
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:Program Files (x86)Microsoft OfficeOffice14MSPPT.OLB"
Call addPPT2000
Call CreateSlides
MsgBox "Powerpoint Presentation build complete.", vbOKOnly
End Sub
Sub addPPT2000()
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:Program Files (x86)Microsoft OfficeOffice14MSPPT.OLB"
Const imgFileName = "PrintIcon"
Const GUIDRef = "{91493440-5A91-11CF-8700-00AA0060263B}"
Set PrntIcon = Application.CommandBars.FindControl(ID:=4)
On Error Resume Next 'Ignore Error If Reference Already Established
ThisWorkbook.VBProject.References.AddFromGuid GUIDRef, 2, 7
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:Program Files (x86)Microsoft OfficeOffice14MSPPT.OLB"
End Sub
Sub CreateSlides()
'Dim the Excel objects
Dim objWorkbook As New Excel.Workbook
Dim objWorksheet As Excel.Worksheet
'Dim the File Path String
Dim strFilePath As String
'Dim the PowerPoint objects
Dim PPT As Object
Dim pptSlide As PowerPoint.Slide
Dim pptLayout As PowerPoint.CustomLayout
Dim pptNewSlide As PowerPoint.Slide
Dim str As String
Dim Title As String
Dim oPPtShp As PowerPoint.Shape
Set PPT = GetObject(, "PowerPoint.Application")
PPT.Visible = True
'Get the layout of the first slide and set a CustomLayout object
Set pptLayout = PPT.ActivePresentation.Slides(1).CustomLayout
'Run the OpenFile function to get an Open File dialog box. It returns a String containing the file and path.
strFilePath = OpenFile()
'Open the Excel file
Set objWorkbook = Excel.Application.Workbooks.Open(strFilePath)
'Grab the first Worksheet in the Workbook
Set objWorksheet = objWorkbook.Worksheets(1)
'Loop through each used row in Column A
For i = 2 To objWorksheet.Range("A65536").End(xlUp).Row
Set PPT = GetObject(, "PowerPoint.Application")
Set pptNewSlide = PPT.ActivePresentation.Slides.AddSlide(PPT.ActivePresentation.Slides.Count + 1, pptLayout)
PPT.ActivePresentation.Slides(1).Shapes("picture 9").Copy
pptNewSlide.Shapes.Paste
'Get the number of columns in use on the current row
Dim LastCol As Long
Dim boldWords As String
'Find the words to bold
boldWords = "Release Date: ,Distributor: ,Director: ,Genre: ,Starring: "
LastCol = objWorksheet.Rows(i).End(xlToRight).Column
If LastCol = 16384 Then LastCol = 1 'For some reason if only column 1 has data it returns 16384, so correct it
'Build a string of all the columns on the row
str = ""
str = "Release Date: " & str & objWorksheet.Cells(i, 4).Value & Chr(13) & _
"Distributor: " & objWorksheet.Cells(i, 18).Value & Chr(13) & _
"Director: " & objWorksheet.Cells(i, 7).Value & Chr(13) & _
"Genre: " & objWorksheet.Cells(i, 16).Value & Chr(13) & _
"Starring: " & objWorksheet.Cells(i, 10).Value & Chr(13) & Chr(13) & _
objWorksheet.Cells(i, 6).Value
sfile = Cells(i, 13) & ".jpg"
Set PPT = GetObject(, "PowerPoint.Application")
'Write the string to the slide
pptNewSlide.Shapes(2).TextFrame.TextRange.Text = objWorksheet.Cells(i, 2).Value 'This enters the film Title
PPT.ActivePresentation.Slides(PPT.ActivePresentation.Slides.Count).Shapes(1).TextFrame.TextRange.Text = str
BoldSomeWords PPT.ActivePresentation.Slides(PPT.ActivePresentation.Slides.Count).Shapes(1), str, boldWords
'~~> Get hold of PPT instance
Set PPT = GetObject(, "Powerpoint.Application")
'~~> Reference the slide which contains picture placeholders
Set pptSlide = PPT.ActivePresentation.Slides(PPT.ActivePresentation.Slides.Count)
Imagenum = 1
For Each oPPtShp In pptSlide.Shapes.Placeholders
' Run the Error handler "ErrHandler" when an error occurs.
Const SpecialCharacters As String = "!,@,#,$,%,^,&,*,(,),{,[,],},:,."
Dim originalstring As String
Dim convertedstring As String
On Error Resume Next
'~~> Only need to work on Picture place holders
If oPPtShp.PlaceholderFormat.Type = ppPlaceholderPicture Then
With oPPtShp
oPPtShpName = oPPtShp.Name
pptSlide.Shapes(oPPtShpName).Select
If oPPtShp.Name = oPPtShpName And Imagenum = 1 Then paths = "C:"
If oPPtShp.Name = oPPtShpName And Imagenum = 2 Then paths = "C:"
If oPPtShp.Name = oPPtShpName And Imagenum = 3 Then paths = "C:"
If oPPtShp.Name = oPPtShpName And Imagenum = 1 Or oPPtShp.Name = oPPtShpName And Imagenum = 2 Then originalstring = objWorkbook.Worksheets(1).Cells(i, 2).Value
convertedstring = "Test" 'originalstring
For Each char In Split(SpecialCharacters, ",")
convertedstring = Replace(convertedstring, char, " ")
Next
If oPPtShp.Name = oPPtShpName And Imagenum = 1 Then pptSlide.Shapes.AddPicture paths & convertedstring & ".jpg", msoFalse, msoTrue, _
.Left, .Top, .Width, .Height Else
If oPPtShp.Name = oPPtShpName And Imagenum = 2 Then pptSlide.Shapes.AddPicture paths & convertedstring & " - Copy" & ".jpg", msoFalse, msoTrue, _
.Left, .Top, .Width, .Height Else
If oPPtShp.Name = oPPtShpName And Imagenum = 3 Then pptSlide.Shapes.AddPicture paths & convertedstring & " - Copy (2)" & ".png", msoFalse, msoTrue, _
.Left, .Top, .Width, .Height
' If oPPtShp.Name = oPPtShpName And Imagenum = 3 Then pptSlide.Shapes.AddPicture paths & objWorkbook.Worksheets(1).Cells(i, 11).Value & " - Copy (2)" & ".png", msoFalse, msoTrue, _
.Left, .Top, .Width, .Height
DoEvents
End With
Imagenum = Imagenum + 1
End If
Next
On Error Resume Next
'Assign the Trailer to the Powerpoint View Trailer Image
Set oSh = pptSlide.Shapes("WatchTrailer")
With oSh.ActionSettings(ppMouseClick)
.Hyperlink.Address = objWorksheet.Cells(i, 8).Value
End With
Set oPPtSlide = Nothing
Set oPPt = Nothing
Next
End Sub
Function OpenFile()
'Dim the File Dialog object and string
Dim objFileDialog As FileDialog
Dim strFile As String
'Set the objFileDialog to an instance of the FileDialog object
Set objFileDialog = Application.FileDialog(msoFileDialogFilePicker)
'Set the Properties of the objFileDialog object
objFileDialog.AllowMultiSelect = False
objFileDialog.ButtonName = "Select"
objFileDialog.InitialView = msoFileDialogViewDetails
objFileDialog.Title = "Select Excel File"
objFileDialog.InitialFileName = "C:"
objFileDialog.Filters.Clear
objFileDialog.Filters.Add "Excel", "*.xls; *.xlsx", 1
objFileDialog.FilterIndex = 1
'Show the FileDialog box
objFileDialog.Show
'Set strFile to the first record of the SelectedItems property of our FileDialog
strFile = objFileDialog.SelectedItems(1)
'Return the File Path string
OpenFile = strFile
End Function
Sub BoldSomeWords(shp As Object, str As String, boldWords As String)
Dim word As Variant
Dim iStart As Integer, iEnd As Integer
'Convert the list of words in to an iterable array, and
' iterate it.
For Each word In Split(boldWords, ",")
'Loop just in case there are duplicates
Do Until InStr(iEnd + 1, str, word) = 0
iStart = InStr(iStart + 1, str, word)
iEnd = iStart + Len(word)
shp.TextFrame.TextRange.Characters(iStart, Len(word)).Characters.Font.Bold = msoTrue
Loop
Next
End Sub
不同版本的PPT对占位符的行为不同。如果你添加一个图像，有些会自动将图像放到第一个可用的空内容或图片占位符中，有些会直接将图像放到幻灯片上。
我更倾向于记录每个占位符的位置/大小，然后删除它们。然后放入图像并将其定位/大小匹配。
如果您出于某种原因必须使用占位符(我确信有很多很好的理由)，您可能希望在代码中分发一个虚拟的"不可用"图像，并在所需的图像不可用时将其放入。
还是……也许更好的是……如果图像不可用并且它是一个内容占位符，则放入一些虚拟文本，一些独特的内容。现在PH值不再是空的，所以当你放入下一个图像时，它不会进入PH值。最后，在最后，寻找任何PH类型的形状，如果它们包含你唯一的文本，删除文本(再次留下一个空的PH值)。
一些可能值得一试的东西(尽管Steve说不同版本的行为不同)
将图片添加到临时空白幻灯片并剪切在真实幻灯片上选择正确的占位符
ActiveWindow.View.Paste