Insert Image from Website - unable to get insert property of image

[JohnDoe1976]

Hi all, I've trailed a LOT of posts trying to find the answer, and I've seen similar issues but not this one.

Essentially I'm trying to insert this image (+others) into my workbook:

https://digitalcontent.api.tesco.com/v2/media/ghs/cb5c0271-087a-4f78-94d0-abe242d51d69/4840f76e-217e-4c1e-bd1b-4ad962e52863.jpg

but I'm getting this:

code is below:

Sub URLPictureInsert()
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
'On Error Resume Next (commented out for now)
Application.ScreenUpdating = False
LR = Sheets("Range Vis").Range("E65536").End(xlUp).Row
Set Rng = Sheets("Range Vis").Range("E3:E" & LR)
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 + 13
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
If .Width > xRg.Width Then .Width = xRg.Width * 2 / 3
If .Height > xRg.Height Then .Height = xRg.Height * 2 / 3
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
End With
lab:
Set Pshp = Nothing
Range("A2").Select
Next
Application.ScreenUpdating = True
End Sub

Can anyone help please?

 

[Domenic]

When I try using Pictures.Insert for inserting your image, I too get the same error.

And when I try using Shapes.AddPicture instead, it too generates a run-time error, saying that the specified file wasn't found.

Here's an alternative that seems to work. You'll need to amend it in order to suit your needs. It first downloads the image onto your local hard drive using the XMLHTTP object. Then it inserts the image onto the active worksheet. And then it deletes the downloaded file.

Option Explicit

Sub test()

    Dim webFilename As String
    webFilename = "https://digitalcontent.api.tesco.com/v2/media/ghs/cb5c0271-087a-4f78-94d0-abe242d51d69/4840f76e-217e-4c1e-bd1b-4ad962e52863.jpg"
    
    Dim localFilename As String
    localFilename = Environ("temp") & "\temp.gif"
    
    Dim errorMessage As String
    If Not DownloadFile(webFilename, localFilename, errorMessage) Then
        MsgBox errorMessage, vbCritical, "Error"
        Exit Sub
    End If
    
    Dim pic As Picture
    Set pic = ActiveSheet.Pictures.Insert(localFilename)
    
    With pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = Range("A2").Left
        .Top = Range("A2").Top
    End With

    Kill localFilename
    
End Sub

Public Function DownloadFile(ByVal webFilename As String, ByVal localFilename As String, ByRef errorMessage As String) As Boolean

    Dim xmlReq As Object
    Set xmlReq = CreateObject("MSXML2.XMLHTTP")
    
    With xmlReq
        .Open "GET", webFilename, False
        .send
        Do While .readystate <> 4
            DoEvents
        Loop
        If .Status <> 200 Then
            errorMessage = "Error " & .Status & ": " & .StatusText
            Set xmlReq = Nothing
            DownloadFile = False
            Exit Function
        End If
        Dim resp() As Byte
        resp() = .responsebody
    End With
    
    Dim fileNumber As Long
    fileNumber = FreeFile()
    
    Open localFilename For Binary As #fileNumber
        Put #fileNumber, , resp
    Close #fileNumber
    
    Set xmlReq = Nothing
    
    DownloadFile = True
    
End Function

Hope this helps!

 

[Jaafar Tribak]

Another api based alternative that I use :

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As LongPtr, lpCLSID As Any) As Long
    Private Declare PtrSafe Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As LongPtr, ByVal punkCaller As LongPtr, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
#Else
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
    Private Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
#End If

Public Function apiInsertPicture(ByVal InsertSheet As Worksheet, ByVal Filename As String) As Picture

    Dim bIPic(15) As Byte
    Dim IPic As Picture
    Dim sExtension As String, sTempFile As String

    If InStrRev(Filename, ".") Then
        sExtension = Right(Filename, Len(Filename) - InStrRev(Filename, "."))
        Call CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), bIPic(0))
        If OleLoadPicturePath(StrPtr(Filename), 0&, 0&, 0&, bIPic(0), IPic) = 0 Then
            sTempFile = Environ("temp") & "\" & Second(Now) & "." & sExtension
            stdole.SavePicture IPic, sTempFile
            Set apiInsertPicture = InsertSheet.Pictures.Insert(sTempFile)
            Kill sTempFile
        End If
    End If

End Function

Usage example:

Sub Test()

    Dim oPic As Picture
    
    Set oPic = apiInsertPicture(ActiveSheet, "https://digitalcontent.api.tesco.com/v2/media/ghs/cb5c0271-087a-4f78-94d0-abe242d51d69/4840f76e-217e-4c1e-bd1b-4ad962e52863.jpg")

    If Not oPic Is Nothing Then
        With oPic
            .ShapeRange.LockAspectRatio = msoFalse
            .Left = Range("A2").Left
            .Top = Range("A2").Top
            .Width = 150
            .Height = 150
        End With
    Else
        MsgBox "Failed to insert picture.", vbExclamation
    End If

End Sub