Multiple images into excel using VBA

Question

I have to write a script that parses the images from ppt and dumps into excel. To do this, I first export all the images in the slides to a folder and then call excel Application to import them into the worksheet. The following code, which I found online, with my modifications is as follows:

Sub ExtractImagesFromPres()

Dim oSldSource As Slide
Dim oShpSource As Shape
Dim Ctr As Integer
Dim ObjExcel As Object
Dim wb As Object
Dim ws As Object
Set ObjExcel = CreateObject("Excel.Application")
Dim sPath As String

sPath = "C:\Users\Aravind_Sampathkumar\Documents\Expor"
Ctr = 0

Set wb = ObjExcel.Workbooks.Open("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
Set ws = wb.Sheets(1)

'Open oPres.Path & PathSep & "Book1.CSV" For Output As iFile

For Each oSldSource In ActivePresentation.Slides
    For Each oShpSource In oSldSource.Shapes

        If oShpSource.Type = msoPicture Then

        ' Hidden Export method

        Call oShpSource.Export(sPath & "Img" & Format(Ctr, "0000") & ".JPG", ppShapeFormatJPG)


        Ctr = Ctr + 1
        End If

        Next oShpSource
Next oSldSource


Folderpath = "C:\Users\Aravind_Sampathkumar\Documents\Expor"
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
counter = 1
For Each fls In listfiles
    strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then

            counter = counter + 1
           ' ws.Range("C" & counter).Value = fls.Name
            ws.Range("D" & counter).ColumnWidth = 25
            ws.Range("D" & counter).RowHeight = 100
            ws.Range("D" & counter).Activate
            'Call insert(strCompFilePath, counter)
            ws.Shapes.AddPicture strCompFilePath, True, True, 100,100,70,70
            End If
        End If
Next
'ws.Shapes.AddPicture ("C:\Users\Aravind_Sampathkumar\Documents")
     'With .ShapeRange
      '  .LockAspectRatio = msoTrue
       ' .Width = 100
        '.Height = 100
    'End With
   ' .Left = ws.Cells(i, 20).Left
    '.Top = ws.Cells(i, 20).Top
    '.Placement = 1
    '.PrintObject = True
'End With
End Sub

When I run it, the images get dumped into excel but all the images are overlapped on each other in the same cell. Is there any way I can modify it such that images go into consecutive rows? 1 image per row?

Answer 1

I'm 100% certain you can export the images from PPT directly to XLS, but I'm not really sure how to do that. However, since you are able to export those images from PPT into a folder, and you just need help importing the images from there, I thin the code below will do just what you want.

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

Application.ScreenUpdating = False
fPath = "C:\your_path_here\"
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 <> ""
        If fName = r.Value Then
            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
        End If
        fName = Dir
    Loop
    i = i + 1
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:\Users\Public\Pictures\Sample 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

This puts them a row apart but you would need to size them appropriately. Note I changed your paths for test paths.

Option Explicit

Sub ExtractImagesFromPres()

    Dim oSldSource As Slide
    Dim oShpSource As Shape
    Dim Ctr As Integer
    Dim ObjExcel As Object
    Dim wb As Object
    Dim ws As Object
    Set ObjExcel = CreateObject("Excel.Application")
    Dim sPath As String

    sPath = "C:\Users\User\Desktop\TestFolder" '"C:\Users\Aravind_Sampathkumar\Documents\Expor"
    Ctr = 0

    Set wb = ObjExcel.Workbooks.Open("C:\Users\User\Desktop\TestFolder\Test.xlsx") '("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
    ObjExcel.Visible = True

    Set ws = wb.Sheets(1)

    For Each oSldSource In ActivePresentation.Slides
        For Each oShpSource In oSldSource.Shapes
            If oShpSource.Type = msoPicture Then
                Call oShpSource.Export(sPath & "\" & "Img" & Format(Ctr, "0000") & ".JPG", ppShapeFormatJPG)
                Ctr = Ctr + 1
            End If
        Next oShpSource
    Next oSldSource

    Dim Folderpath As String
    Dim fso As Object
    Dim NoOfFiles As Long
    Dim listfiles As Object
    Dim counter As Long
    Dim fls As Variant
    Dim strCompFilePath As String

    Folderpath = "C:\Users\User\Desktop\TestFolder" '"C:\Users\Aravind_Sampathkumar\Documents\Expor"
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files

    counter = 1

    For Each fls In listfiles
        strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> vbNullString Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
                Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
                Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then

                counter = counter + 1
                ' ws.Range("C" & counter).Value = fls.Name
                ws.Range("D" & counter).ColumnWidth = 25
                ws.Range("D" & counter).RowHeight = 100
                ws.Range("D" & counter).Activate
                'Call insert(strCompFilePath, counter)
                With ws.Pictures.Insert(strCompFilePath)
                    .Left = ws.Cells(counter, "D").Left
                    .Top = ws.Cells(counter, "D").Top
                End With
            End If
        End If
    Next
End Sub

Answer 3

Here's a version that uses copy/paste instead of export/import - it does include the line to change the row height if you want to crib just that.. :P

Sub ExtractImagesFromPres()
    Dim oSldSource As Slide
    Dim oShpSource As Shape
    Dim ObjExcel As Object
    Dim wb As Object
    Dim ws As Object
    Set ObjExcel = CreateObject("Excel.Application")
    Dim lOffset AS Long

    Set wb = ObjExcel.Workbooks.Open("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
    Set ws = wb.Sheets(1)

    'Open oPres.Path & PathSep & "Book1.CSV" For Output As iFile
    lOffset = 5
    For Each oSldSource In ActivePresentation.Slides
        For Each oShpSource In oSldSource.Shapes
            If oShpSource.Type = msoPicture Then
                oShpSource.Copy
                ws.Paste
                With ws.Shapes(ws.Shapes.Count)
                    .Top = lOffset 
                    .Left = 5
                    .Placement = 3 'xlFreeFloating
                    'This line sets the row height!
                    .TopLeftCell.EntireRow.RowHeight = 10 + .Height
                    lOffset = lOffset + .Height + 10
                End With
            End If
        Next oShpSource
    Next oSldSource

    'Optional Tidy-Up code
    'Set ws = Nothing
    'wb.Save
    'Set wb = Nothing
    'ObjExcel.Quit
    'Set ObjExcel = Nothing
End Sub

Answer 4

Have a look at the documentation for the AddPicture method:

https://msdn.microsoft.com/en-us/vba/excel-vba/articles/shapes-addpicture-method-excel

expression.AddPicture(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)

Rather than adding the picture at the active cell, it's location is controlled by the Left and Top arguments. You can use the Left and Top properties of the target cell as the arguments of the AddPicture method:

ws.Shapes.AddPicture strCompFilePath, True, True, ws.Range("D" & counter).Left, ws.Range("D" & counter).Top,70,70