根据 Excel 中的单元格值从文件夹插入图片到 PowerPoint

Question

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

我的设备上的文件夹中有五张图片 (.png)。
Excel 中的单元格值从 1 到 5。

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

例如：如果 Excel 值 = 2，则在 PowerPoint 表格中插入图片 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 表格不能容纳图形，只能容纳文本。您可以使用图片的“顶部”和“左侧”属性将图片放置在网格中，但使用表格来定位它们是行不通的。

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

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