在 Powerpoint 中使用 VBA 將圖像轉換為命名占位符（來自 Excel）或在找不到圖像時輸入不同的圖像

Question

如何在 Powerpoint 中使用 VBA 將圖像添加到特定的命名占位符（來自 Excel）

一段時間以來，我一直試圖弄清楚這一點。 我已經復制了下面的所有代碼。 我嘗試做的是將 3 個圖像以我提供的格式添加到 Powerpoint。 我遇到的問題是，當找不到圖像時（我已經告訴系統恢復），下一個圖像出現在前一個占位符中。 不是我想要的。 PowerPoint 已打開，正如您所看到的，我什至嘗試選擇占位符以查看是否有所不同。 如果沒有解決這個問題。 任何人都可以建議如何捕獲未填充的圖像，因此我可以填充一個顯示“圖像不可用”的圖像只是為了將所有內容都放在正確的位置？

在下面搜索： If oPPtShp.PlaceholderFormat.Type = ppPlaceholderPicture 然后找到我加載圖像的 IF 的開始。

請幫忙！

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

不同版本的 PPT 在占位符上的表現不同。 如果您添加圖像，有些會自動將圖像拖放到第一個可用的空白內容或圖片占位符中，有些則會將圖像拖放到幻燈片上。

我更傾向於記錄每個占位符的位置/大小，然后刪除它們。 然后放入圖像並放置/調整它們以匹配。

如果您出於某種原因必須使用占位符（我相信有很多充分的理由），您可能希望隨代碼分發一個虛擬的“不可用”圖像，並在所需圖像不可用時將其放入.

或者......也許更好......如果圖像不可用並且它是內容占位符，請放入一些虛擬文本，一些獨特的東西。 現在 PH 不再是空的，所以當你放入下一張圖片時，它不會進入那個 PH。 最后，最后，查找任何 PH 類型的形狀，如果它們包含您的獨特文本，請刪除該文本（再次為您留下一個空的 PH）。

Answer 2

可能值得一試的東西（盡管正如史蒂夫所說，版本的行為有所不同）

將圖片添加到臨時空白幻燈片並剪切 在真實幻燈片上選擇正確的占位符

ActiveWindow.View.Paste