CODEWITHSUNDEEP
excelvbaimageexportpowerpoint
user22857676
user22857676

Reputation: 1

How to insert an image from an excel cell into powerpoint using VBA?

Slides output with 1 text +1 picture, 2 text + 1 pictureI want to introduce 3 more Text Placeholders totalling to 4.My picture is in the 4th column in the excelsheet. But when I introduce even the 2nd TextPlaceholder, the picture is not in the picture placeholder. So, I had modified the code as

Sld.Shapes.Placeholders(1).TextFrame.TextRange.Text = DataRow.Cells(1, 1)
            Sld.Shapes.Placeholders(2).TextFrame.TextRange.Text = DataRow.Cells(1, 2)
            Sld.Shapes.Placeholders(3).TextFrame.TextRange.Text = DataRow.Cells(1, 3)
                        
            sCell = DataRow.Cells(1, 4).Address
            ' Check if there is a shp in Column 3
            If objDic.exists(sCell) Then
                objDic(sCell).Copy
                Sld.Shapes.Placeholders(4).Select
                Sld.Shapes.PasteSpecial DataType:=ppPasteMetafilePicture
            End If

The output is the same even with 4 text placeholders. The picture is not in PicturePlaceholder. Tried several times. Not able to figure out where am I going wrong? Can I be helped?

The first 2 rows are with images in textbox and the next two are imprted to cell as image without textboxI have an excelsheet of three columns A, B and C. The 1st two columns have text and the third column C has image embedded in text box. I have 1000s of rows. I want to export these columns to PPT slides. I have got three placeholders in the slidemaster of PPT. The first two placeholders are for inserting text and the third for inserting image. I have written a vba macro for the exporting text of 1st two columns from excel to ppt. Working fine. I want to know how to insert image from third column of excel sheet(image is in textbox) in the third placeholder meant for the image. The program is as follows.

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

The placeholders for first two columns works fine. I have images in the third column and want to isert in the thrid placeholder in ppt meant for pictures. Any solutions? Thanks in advance

I tried and succeeded in inserting text but not the image.Fairly new to VBA.

Upvotes: 0

Views: 406

Answers (1)

taller
taller

Reputation: 18778

The pictures on cells is a good approach. It is easier to manipulate with VBA code.

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

Microsoft documentation:

Shapes.PasteSpecial method (PowerPoint)

enter image description here

Upvotes: 1

Related Questions