在 Powerpoint 中使用 VBA 将图像转换为命名占位符（来自 Excel）或在找不到图像时输入不同的图像

Question

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

Answer 1

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).

Answer 2

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