Excel add image to workbook from URL using shapes.AddPicture VBA Macro-CodePudding

So I have the following code that works correctly and uses a column with URLs to add the images to the next column. The problem being that if you send it to someone, it breaks. I want to switch this to shapes.AddPicture so the pictures will follow the spreadsheet. I found something that works but it doesn't add the pictures to the individual cells like the below solution does.

 Sub URLPictureInsert()

    Dim Pshp As Shape
    Dim xRg As Range
    Dim xCol As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    Set Rng = ActiveSheet.Range("T3:T25")
    For Each cell In Rng
        filenam = cell
        ActiveSheet.Pictures.Insert(filenam).Select
        Set Pshp = Selection.ShapeRange.Item(1)
        If Pshp Is Nothing Then GoTo lab
        xCol = cell.Column   1
        Set xRg = Cells(cell.Row, xCol)
        With Pshp
            .LockAspectRatio = msoFalse
            .Width = 70
            .Height = 100
            .Top = xRg.Top   (xRg.Height - .Height) / 2
            .Left = xRg.Left   (xRg.Width - .Width) / 2
        End With
lab:
    Set Pshp = Nothing
    Range("T2").Select
    Next
    Application.ScreenUpdating = True
End Sub

This one works but it adds the images one on top of the other in the same area - I would like it to dynamically place the images like the one above does

Sub URLPhotoInsert()
    Dim cShape As Shape
    Dim cRange As Range
    Dim cColumn As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    Set xRange = ActiveSheet.Range("j3:j4")
    For Each cell In xRange
        cName = cell
        ActiveSheet.Shapes.AddPicture (cName), True, True, 100, 100, 70, 70
        Set cShape = Selection.ShapeRange.Item(1)
        If cShape Is Nothing Then GoTo line22
        cColumn = cell.Column - 1
        Set cRange = Cells(cell.Row, cColumn)
      
line22:
        Set cShape = Nothing
        Range("D5").Select
    Next
    Application.ScreenUpdating = True
End Sub

CodePudding user response：

I finally found something that worked for me - for those of you who want the pictures stored with the file using a URL for the source

 Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String

Sub URLPictureInsert()
    Dim theShape As Shape
    Dim xRg As Range
    Dim xCol As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    ' Set to the range of cells you want to change to pictures
    Set rng = ActiveSheet.Range("T1206:T1400")
    For Each cell In rng
        Filename = cell
        ' Use Shapes instead so that we can force it to save with the document
        Set theShape = ActiveSheet.Shapes.AddPicture( _
            Filename:=Filename, linktofile:=msoFalse, _
            savewithdocument:=msoCTrue, _
            Left:=cell.Left, Top:=cell.Top, Width:=15, Height:=15)
        If theShape Is Nothing Then GoTo isnill
        With theShape
            .LockAspectRatio = msoTrue
            ' Shape position and sizes stuck to cell shape
            .Top = cell.Top   1
            .Left = cell.Left   1
            .Height = cell.Height - 2
            .Width = cell.Width - 2
            ' Move with the cell (and size, though that is likely buggy)
            .Placement = xlMoveAndSize
        End With
        ' Get rid of the
        cell.ClearContents
isnill:
        Set theShape = Nothing
        Range("D2").Select

    Next
    Application.ScreenUpdating = True

    Debug.Print "Done " & Now


End Sub