How to add image to specific named placeholder using VBA in Powerpoint (from Excel)
I've been trying to figure this one out for a while. I've copied all my code below. What I am try to do I add 3 images to a Powerpoint in a format that I was provided. The problem I experience, is that, when an imge isn't found (I've told the system to resume), the next image appears in the previous Placeholder. Not in the one I want it to. The PowerPoint is Open, and as you can see, I've even tried selecting the placeholder to see if that makes a difference. If there isn't a work around for this. Can anyone suggest how to capture that an Image didn't populate, so I can populate with an image that says "Image not available" Just to keep everything in the right place?
Search below for : If oPPtShp.PlaceholderFormat.Type = ppPlaceholderPicture Then to find the start of the IF where I load in the images.
Please help!
Sub AddPPT2010()
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files (x86)\Microsoft Office\Office14\MSPPT.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 Office\Office14\MSPPT.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 Office\Office14\MSPPT.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 Office\Office14\MSPPT.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
Different versions of PPT behave differently wrt placeholders. If you add an image, some will automatically drop the image into the first available empty content or picture placeholder, some will just drop the image onto the slide.
I'd be more inclined to record the position/size of each placeholder then delete them. THEN drop in the images and position/size them to match.
If you MUST use the placeholders for some reason (and I'm sure there are lots of good reasons), you might want to distribute a dummy "not available" image with your code and drop that in when the needed image isn't available.
Or ... perhaps better yet ... if the image isn't available and it's a content placeholder, put in some dummy text, something unique. Now the PH isn't empty any longer so when you drop in the next image, it won't go into that PH. Finally, at the end, look for any PH type shapes and if they contain your unique text, delete the text (leaving you with an empty PH again).
Something that might be worth a go (though as Steve says versions behave differently)
Add the picture to a temp blank slide and cut Select the correct placehoder on the real slide
ActiveWindow.View.Paste
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.