Multiple images into excel using VBA - 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

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 2

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

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

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