Add image to workbook from URL using shapes.AddPicture

Question

The following code uses a column with URLs to add the images to the next column. It adds the pictures to individual cells.

If you send it to someone, it breaks. I want to switch to shapes.AddPicture so the pictures will follow the spreadsheet.

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 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

The files are on a secure server that you need to logon to access. If you send the file out - the pictures will not load. I want to change the macro to actually copy the files and leave them with the excel sheet. I know the shapes.AddPicture will work with that but I'm having issues getting it to go into the correct cell. — Cheshire Catt, Apr 28 '22 at 12:28

score 0 · Accepted Answer · answered May 03 '22 at 14:16

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

Add image to workbook from URL using shapes.AddPicture

1 Answers1