VBA: Insert Picture in PowerPoint from Folder based on Cell Value from Excel-CodePudding

I have spent i a lot of time trying to write a VBA-code to automate my work, but can't figure out how. I hope someone in here can help me.

The goal is to insert pictures in a tabel in a PowerPoint from a Folder based on values in Excel.

I have 5 different pictures (.png) located in a folder on my device. The cell values in Excel goes from 1 to 5.

Depending on the cell value, I would like one of the 5 pictures to be inserted in a table in Powerpoint.

E.g.: If excel-value = 2 then insert picture2 in powerpoint-table.

I hope the above make sense, and I hope someone can help me.

I have tried the following:

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

I know the above is probably completely wrong but I am lost :/

CodePudding user response：

Maybe something like this.

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

CodePudding user response：

One small glitch: PowerPoint tables can't hold graphics, just text. You can position your pictures in a grid by using their Top and Left properties, but using a table for positioning them will not work.

You can use a picture to fill a cell as a background, but the cell dimensions must match the picture's to avoid distortion. To do this, use a statement like:

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