VBA - Insert Multiple Images into a sheet

[Tarkin]

Hi

I have searched everywhere but somehow the VBA codes I found on the web to do this routine have not worked.

This is what I am trying to do:

I have a set of images (PNG format) located in a folder (C:\MyImages)

I want a VBA code to automatically load these into a workbook (in a sheet called 'Screenshots') and insert them in cells of Column B. These cells have been resized to accommodate an ideal resolution size of the images.

Ideally, I would like the file name of each images to be inserted in Column A cells, next to the relevant image.

Any help would be greatly appreciated!

Thanks

 

[DanteAmor]

Try with this code

Sub Insert_Multiple_Images()
'
    Dim wPath As String, i As Long, wFile As Variant
    Dim sh As Worksheet
    
    Application.ScreenUpdating = False
    Set sh = Sheets("Screenshots")
    sh.DrawingObjects.Delete
    sh.Cells.ClearContents
    
    wPath = "C:\MyImages\"
    If Right(wPath, 1) <> "\" Then wPath = wPath & "\"
    i = 2
    wFile = Dir(wPath & "*.png")
    
    Do While wFile <> ""
        With sh.Pictures.Insert(wPath & wFile)
            .Placement = xlMoveAndSize
            .ShapeRange.LockAspectRatio = msoFalse
            .Top = sh.Cells(i, "B").Top + 1
            .Left = sh.Cells(i, "B").Left + 1
            .Width = sh.Cells(i, "B").Width - 2
            .Height = sh.Cells(i, "B").Height - 2
            sh.Cells(i, "A").Value = wFile
            i = i + 1
        End With
        wFile = Dir()
    Loop
    
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

 

[Exceladd1ct]

Not that good at VBA but please let me know if this will do:

Dim ImgName As String
Dim Path
Path = "C:\MyImages"
ImgName = Dir("C:\MyImages\*.png")
rowNum = 1
Do While ImgName <> ""

With Screenshots.Pictures.Insert(Path & ImgName)
    With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 75
        .Height = 90 'Row height is specified in points, image height is also specified in points
                     'If default size of excel rows is 15 points, the image height will be 90 points = 6 rows
    End With
.Left = Range("B" & rowNum).Left
.Top = Range("B" & rowNum).Top
.Placement = 1
.PrintObject = True
End With
Range("A" & rowNum).Value = ImgName

ImgName = Dir
rowNum = rowNum + 7
Loop

 

[Tarkin]

DanteAmor,your code was flawless and I achieved the result I wanted, many thanks!

Try with this code

Sub Insert_Multiple_Images()
'
    Dim wPath As String, i As Long, wFile As Variant
    Dim sh As Worksheet
    
    Application.ScreenUpdating = False
    Set sh = Sheets("Screenshots")
    sh.DrawingObjects.Delete
    sh.Cells.ClearContents
    
    wPath = "C:\MyImages\"
    If Right(wPath, 1) <> "\" Then wPath = wPath & "\"
    i = 2
    wFile = Dir(wPath & "*.png")
    
    Do While wFile <> ""
        With sh.Pictures.Insert(wPath & wFile)
            .Placement = xlMoveAndSize
            .ShapeRange.LockAspectRatio = msoFalse
            .Top = sh.Cells(i, "B").Top + 1
            .Left = sh.Cells(i, "B").Left + 1
            .Width = sh.Cells(i, "B").Width - 2
            .Height = sh.Cells(i, "B").Height - 2
            sh.Cells(i, "A").Value = wFile
            i = i + 1
        End With
        wFile = Dir()
    Loop
    
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

 

[Tarkin]

Exceladd1ct, I triedyour code but I get an error at

'WithScreenshots.Pictures.insert(Path & ImgName)'

>Am I missingsomething ?

Not that good at VBA but please let me know if this will do:

Dim ImgName As String
Dim Path
Path = "C:\MyImages"
ImgName = Dir("C:\MyImages\*.png")
rowNum = 1
Do While ImgName <> ""

With Screenshots.Pictures.Insert(Path & ImgName)
    With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 75
        .Height = 90 'Row height is specified in points, image height is also specified in points
                     'If default size of excel rows is 15 points, the image height will be 90 points = 6 rows
    End With
.Left = Range("B" & rowNum).Left
.Top = Range("B" & rowNum).Top
.Placement = 1
.PrintObject = True
End With
Range("A" & rowNum).Value = ImgName

ImgName = Dir
rowNum = rowNum + 7
Loop

 

[DanteAmor]

DanteAmor,your code was flawless and I achieved the result I wanted, many thanks!

I'm glad to help you. Thanks for the feedback.

 

[Exceladd1ct]

Sorry for big delay, My mistake:

Dim ImgName As String
Dim Path
Path = "C:\MyImages"
ImgName = Dir("C:\MyImages\*.png")
rowNum = 1
Do While ImgName <> ""

With Sheets("Screenshoots").Pictures.Insert(Path & ImgName)
    With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 75
        .Height = 90 'Row height is specified in points, image height is also specified in points
                     'If default size of excel rows is 15 points, the image height will be 90 points = 6 rows
    End With
.Left = Range("B" & rowNum).Left
.Top = Range("B" & rowNum).Top
.Placement = 1
.PrintObject = True
End With
Range("A" & rowNum).Value = ImgName

ImgName = Dir
rowNum = rowNum + 7
Loop

 

[Tarkin]

The code stops at

With Sheets("Screenshots").Pictures.insert(Path & ImgName)

Sorry for big delay, My mistake:

Dim ImgName As String
Dim Path
Path = "C:\MyImages"
ImgName = Dir("C:\MyImages\*.png")
rowNum = 1
Do While ImgName <> ""

With Sheets("Screenshoots").Pictures.Insert(Path & ImgName)
    With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 75
        .Height = 90 'Row height is specified in points, image height is also specified in points
                     'If default size of excel rows is 15 points, the image height will be 90 points = 6 rows
    End With
.Left = Range("B" & rowNum).Left
.Top = Range("B" & rowNum).Top
.Placement = 1
.PrintObject = True
End With
Range("A" & rowNum).Value = ImgName

ImgName = Dir
rowNum = rowNum + 7
Loop