VBA：根据 Excel 中的单元格值在 PowerPoint 中插入图片

Question

我花了很多时间尝试编写 VBA 代码来自动化我的工作，但不知道如何。我希望这里有人可以帮助我。

目标是根据 Excel 中的值从文件夹中的 PowerPoint 表格中插入图片。

我有5位于我设备上的文件夹中的不同图片 (.png)。 Excel中的单元格值来自1至5.

根据单元格的值，我希望将 5 张图片中的一张插入 Powerpoint 的表格中。

例如：如果 excel-value = 2，则在 powerpoint-table 中插入图片 2。

我希望以上是有道理的，我希望有人可以帮助我。

我尝试了以下方法：

Sub ESG_Globes()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' Define PPT objects
    Dim oPPT            As PowerPoint.Presentation
    Dim appPPT          As PowerPoint.Application
    Dim oWS             As Excel.Worksheet
    Dim fileNameString  As String
    Dim boolUploadToIntranet As Boolean
    Dim cells As Range
    Dim s14 As Integer, s15 As Integer, s13 As Integer
    Dim ESG1, ESG2, ESG3, ESG4, ESG5 As String
    Dim ImageBox, ImageBox2 As PowerPoint.Shape



With oPPT.Slides(8)
            For k = 4 To 22
'Globes PNG Location
ESG1 = "S:\S8RENTE\Credit & Equity Research\ESG\Grafik\Glober (PNG)\SustainabilityRating_Low.png"
ESG2 = "S:\S8RENTE\Credit & Equity Research\ESG\Grafik\Glober (PNG)\SustainabilityRating_BelowAverage.png"
ESG3 = "S:\S8RENTE\Credit & Equity Research\ESG\Grafik\Glober (PNG)\SustainabilityRating_Average.png"
ESG4 = "S:\S8RENTE\Credit & Equity Research\ESG\Grafik\Glober (PNG)\SustainabilityRating_AboveAverage.png"
ESG5 = "S:\S8RENTE\Credit & Equity Research\ESG\Grafik\Glober (PNG)\SustainabilityRating_High.png"
    
    ' Check if file is open - if not, open it
    fOpen = IsFileOpen("S:\S8RENTE\Aktieanalyse\Vaerktoejer\Aktieoverblik\Aktieoverblik - Sektoropdeling\Aktieoverblik_PPT - Sektor.pptx")
    If Not fOpen Then
        Set appPPT = CreateObject(class:="PowerPoint.Application")
        Set oPPT = appPPT.Presentations.Open("S:\S8RENTE\Aktieanalyse\Vaerktoejer\Aktieoverblik\Aktieoverblik - Sektoropdeling\Aktieoverblik_PPT - Sektor.pptx")
    Else
        Set appPPT = GetObject(class:="PowerPoint.Application")
        Set oPPT = appPPT.Presentations("Udkast til Aktieoverblik.pptx")
    End If
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set oWS = ActiveWorkbook.Worksheets("PPT DATA")
    Set owb = ActiveWorkbook
                
                        If oWS.cells(k, 37) = "1" Then
                            Set wdPic = .Cell(k, 37).Range.InlineShapes.AddPicture(filename:=ESG1, _
                            LinkToFile:=False, SaveWithDocument:=True)
                        If oWS.cells(k, 37) = "2" Then
                            Set wdPic = .Cell(k, 37).Range.InlineShapes.AddPicture(filename:=ESG2, _
                            LinkToFile:=False, SaveWithDocument:=True)
                        If oWS.cells(k, 37) = "3" Then
                            Set wdPic = .Cell(k, 37).Range.InlineShapes.AddPicture(filename:=ESG3, _
                            LinkToFile:=False, SaveWithDocument:=True)
                        If oWS.cells(k, 37) = "4" Then
                            Set wdPic = .Cell(k, 37).Range.InlineShapes.AddPicture(filename:=ESG4, _
                            LinkToFile:=False, SaveWithDocument:=True)
                        If oWS.cells(k, 37) = "5" Then
                            Set wdPic = .Cell(k, 37).Range.InlineShapes.AddPicture(filename:=ESG5, _
                            LinkToFile:=False, SaveWithDocument:=True)

                        End If
                            wdPic.Height = 0.3 * 28.34646
                            wdPic.Width = 0.3 * 28.34646
                            Set wdPic2 = wdPic.ConvertToShape
                            wdPic2.Left = CentimetersToPoints(4 - (y * 0.3))
                        y = y + 1
End With
End Sub

我知道上面可能是完全错误的，但我迷路了：/

Answer 1

也许是这样的。

Sub InsertPics()
Dim fPath As String, fName As String
Dim r As Range, rng As Range

Application.ScreenUpdating = False
fPath = "C:Pictures"
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
i = 1
For Each r In rng
    fName = Dir(fPath)
    Do While fName <> ""
            With ActiveSheet.Pictures.Insert(fPath & fName)
                .ShapeRange.LockAspectRatio = msoTrue
                Set px = .ShapeRange
                If .ShapeRange.Width > Rows(i).Columns(2).Width Then .ShapeRange.Width = Columns(2).Width
                    With Cells(i, 2)
                        px.Top = .Top
                        px.Left = .Left
                        .RowHeight = px.Height
                    End With
            End With
            i = i + 1
        fName = Dir
    Loop
Next r
Application.ScreenUpdating = True
End Sub


' Note: you need the file extension, such as ',jpg', or whatever you are using, so you can match on that.
Sub Insert()
    Dim strFolder As String
    Dim strFileName As String
    Dim objPic As Picture
    Dim rngCell As Range
    strFolder = "C:Pictures" 'change the path accordingly
    If Right(strFolder, 1) <> "" Then
        strFolder = strFolder & ""
    End If
    Set rngCell = Range("E1") 'starting cell
    strFileName = Dir(strFolder & "*.jpg", vbNormal) 'filter for .png files
    Do While Len(strFileName) > 0
        Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
        With objPic
            .Left = rngCell.Left
            .Top = rngCell.Top
            .Height = rngCell.RowHeight
            .Placement = xlMoveAndSize
        End With
        Set rngCell = rngCell.Offset(1, 0)
        strFileName = Dir
    Loop
End Sub

Answer 2

一个小故障：PowerPoint 表格不能保存图形，只能保存文本。您可以使用它们的 Top 和 Left 属性将图片放置在网格中，但使用表格来定位它们将不起作用。

您可以使用图片填充单元格作为背景，但单元格尺寸必须与图片匹配以避免失真。为此，请使用如下语句：

ActivePresentation.Slides(1).Shapes(1).Table.Cell(1, 2).Shape.Fill.UserPicture ("C:FilepathFilename")