Add multiple pictures from local directory

[Leonvl]

I uded the below code to insert pictures based on a URL on the web based on a cell value which worked fine.
Now I would like to insert pictures for a range from a local folder, but that apparently doesnt work with the Parent.Pictures.Insert method. Played a bit with the Shapes.AddPicture method but cant get it working. Any thoughts here? Thanks

Sub InsImg()

Dim URL As Range
    
    For Each URL In Worksheets("Sheet1").Range("A4:ZZ4")
    With URL.Parent.Pictures.Insert(URL.Value)
        On Error Resume Next
        .Left = URL.Offset(0, 0).Left + 1
        .Top = URL.Offset(0, 0).Top
        .Height = 250
'        .Width = 420
        URL.EntireRow.RowHeight = .Height
    End With
    Next
End Sub

 

[Leonvl]

It works great! Thanks Domenic!!

 

[Leonvl]

How could I prevent that the image will not be wider than 580 while remaining the aspect ratio?
So if width devided by height > 2.32 than widt should be set at 580 (rather then setting height at 250).

The ideal however would be if the image could be cropped at 580 x 250....

 

[Domenic]

Try...

Option Explicit

Sub InsImg()


    Dim oShape As Shape
    Dim rCell As Range
    Dim sFullName As String
    
    With Worksheets("Sheet1")
        For Each rCell In .Range("A4:ZZ4")
            sFullName = rCell.Value
            If Len(rCell) > 0 Then
                If Len(Dir(sFullName, vbNormal)) > 0 Then
                    Set oShape = .Shapes.AddPicture( _
                        Filename:=sFullName, _
                        LinkToFile:=msoFalse, _
                        SaveWithDocument:=msoTrue, _
                        Left:=rCell.Left, _
                        Top:=rCell.Top, _
                        Height:=-1, _
                        Width:=-1)
                    With oShape
                        If .Width / .Height > 2.32 Then
                            .Width = 580
                        Else
                            .Height = 250
                        End If
                        rCell.EntireRow.RowHeight = .Height
                    End With
                End If
            End If
        Next rCell
    End With
    
End Sub

Hope this helps!