如何使用VBA将Excel单元格中的图像插入到powerpoint中？

Question

我有一个包含三列A、B和C的Excel表格。第一两列有文本，第三列C有嵌入在文本框中的图像。我有 1000 行。我想将这些列导出到 PPT 幻灯片。我在PPT幻灯片母版中有三个占位符。前两个占位符用于插入文本，第三个占位符用于插入图像。我编写了一个 vba 宏，用于将第一两列的文本从 excel 导出到 ppt。工作正常。我想知道如何将 Excel 工作表第三列中的图像（图像位于文本框中）插入到图像的第三个占位符中。 程序如下。

Sub LoopRowsSelected2Choices()
    Dim DataRange As Range
    Dim DataRow As Range
    Dim AppPPT As PowerPoint.Application
    Dim Prs As PowerPoint.Presentation
    Dim Sld As PowerPoint.Slide
    Set AppPPT = GetObject(, "PowerPoint.Application")
    Set Pres = AppPPT.ActivePresentation
    Set DataRange = Selection
    For Each DataRow In DataRange.Rows
        
        Set Sld = Pres.Slides.AddSlide(Pres.Slides.Count + 1, Pres.SlideMaster.CustomLayouts(2))
        Sld.Shapes.Placeholders(1).TextFrame.TextRange.Text = DataRow.Cells(1, 1)
        Sld.Shapes.Placeholders(2).TextFrame.TextRange.Text = DataRow.Cells(1, 2)
     Next DataRow
End Sub

前两列的占位符效果很好。我在第三列中有图像，想要插入 ppt 中用于图片的第三个占位符。有什么解决办法吗？ 预先感谢

我尝试并成功插入了文本，但没有插入图像。对 VBA 来说还很陌生。

Answer 1

细胞上的图片是一个好方法。使用VBA代码更容易操作。

Option Explicit

Sub LoopRows()
    Dim DataRange As Range
    Dim DataRow As Range
    Dim AppPPT As PowerPoint.Application
    Dim Pres As PowerPoint.Presentation
    Dim Sld As PowerPoint.Slide
    Dim objDic As Object, Shp As Shape, i As Integer
    Dim sCell As String
    Set AppPPT = GetObject(, "PowerPoint.Application")
    Set Pres = AppPPT.ActivePresentation
    ' Verify the Selection is a Range object
    If TypeName(Selection) = "Range" Then
        ' Load Dict, Key = TopLeftCell.Address, Value = Shp object
        Set objDic = CreateObject("scripting.dictionary")
        For i = 1 To ActiveSheet.Shapes.Count
            Set Shp = ActiveSheet.Shapes(i)
            If Not Application.Intersect(Shp.TopLeftCell, Selection) Is Nothing Then
                Set objDic(Shp.TopLeftCell.Address) = Shp
            End If
        Next
        Set DataRange = Selection
        ' Loop through data row
        For Each DataRow In DataRange.Rows
            Set Sld = Pres.Slides.AddSlide(Pres.Slides.Count + 1, Pres.SlideMaster.CustomLayouts(2))
            Sld.Select
            Sld.Shapes.Placeholders(1).TextFrame.TextRange.Text = DataRow.Cells(1, 1)
            Sld.Shapes.Placeholders(2).TextFrame.TextRange.Text = DataRow.Cells(1, 2)
            sCell = DataRow.Cells(1, 3).Address
            ' Check if there is a shp in Column 3
            If objDic.exists(sCell) Then
                objDic(sCell).Copy
                Sld.Shapes.Placeholders(3).Select
                Sld.Shapes.PasteSpecial DataType:=ppPasteMetafilePicture
            End If
        Next DataRow
    End If
End Sub