Insert picture from a webpageURL into excel using macros

[cjain_560]

HI guys, I hope somebody can help me here. I'm using Windows 10, Microsoft office 365.

1) I have many webpage URL with me in Column A. Using VBA, I want to extract an image from one webpage URL and put it in the next respective column. (Please note, it is a webpage URL, EX:

Chicco 6 Feeding Bottle Steriliser | White | Warmers & Sterilisers From this URL, I want to extract the first image which is on display and put it in the second column of my excel sheet.

I'm using this VBA Code, but all it does is get the logo from the site and puts it in the second column. Please note: All my references are in place and code is working, its just I'm not getting the image on display. Option Explicit Public Sub InsertPicturesFromWeb() Dim IE As InternetExplorer Dim HTMLdoc As HTMLDocument Dim imgElements As IHTMLElementCollection Dim imgElement As HTMLImg Dim aElement As HTMLAnchorElement Dim N As Integer, I As Integer Dim Url As String, Url2 As String Dim LastRow As Long Dim M, sImageSearchString LastRow = Range("A" & Rows.Count).End(xlUp).Row For I = 1 To LastRow Url = "https://www.babyshopstores.com/ae/en/p/" & Cells(I, 1) Set IE = New InternetExplorer With IE .Visible = True .Navigate Url Do Until .readyState = 4: DoEvents: Loop Set HTMLdoc = .document Set imgElements = HTMLdoc.getElementsByTagName("IMG") N = 1 For Each imgElement In imgElements If InStr(imgElement.src, sImageSearchString) Then If imgElement.ParentNode.nodeName = "A" Then Set aElement = imgElement.ParentNode Url2 = imgElement.src N = N + 1 End If End If Next Call GetShapeFromWeb(Url2, Cells(I, 2)) IE.Quit Set IE = Nothing End With Next I End Sub Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range) With rngTarget.Parent .Pictures.Insert strShpUrl .Shapes(.Shapes.Count).Left = rngTarget.Left .Shapes(.Shapes.Count).Top = rngTarget.Top End With End Sub

 

[cjain_560]

Hey Anthony,

I'm getting an initialization error I think. I'm attaching the screenshot here as well as the full VBA Code. I think it's because of the initialization above the sub or wrong initialization of "npicname".

Again, Thank you so much for your help all this time, you really made it easy for me.

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
        Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
        ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Public Sub InsertPicturesFromWeb()
    Dim IE As InternetExplorer
    Dim HTMLdoc As HTMLDocument
    Dim I As Integer
    Dim URL As String, Url2 As String
    Dim LastRow As Long
    Dim oObj As Object, npicname
    Dim newpic As Variant
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Set IE = New InternetExplorer
    For I = 1 To LastRow
        URL = "https://www.babyshopstores.com/ae/en/p/" & Cells(I, 1)
        With IE
            .Visible = False
            .Navigate URL
            Do While .Busy: DoEvents: Loop
            Do Until .readyState = 4: DoEvents: Loop
            Set HTMLdoc = .document
            Set oObj = HTMLdoc.getElementById("thmb-01")
            Url2 = oObj.src
            npicname = GetWebFile(Url2, "C:\Photos")
            If npicname <> 0 Then
                Set newpic = ActiveSheet.Shapes.AddPicture(npicname, msoFalse, msoTrue, Cells(I, 2).Left, Cells(I, 2).Top, -1, -1)
            End If
        End With
    Next I
    IE.Quit
    Set IE = Nothing
End Sub

Function GetWebFile(ByVal myURL, ByVal myPath As String) As Variant

Dim PathNName As String, URL As String
Dim mySplit, Resp As Long
mySplit = Split(myURL, "/")
PathNName = myPath & mySplit(UBound(mySplit))
Resp = URLDownloadToFile(0, myURL, PathNName, 0, 0)
If Resp = 0 Then
    GetWebFile = PathNName
    Exit Function
Else
    GetWebFile = 0
End If
End Function

 

[cjain_560]

Hey Anthony, please ignore the last post, I was able to rectify the error. Thank you so much for your help, the code is working now. Much much appreciated.

 

[Anthony47]

You fixed it, but ANYWAY:
Don't put this code into a "sheet class module", but in a Standard vba module:
-from the vba interface, Menu /Insert /Module; then remove all the code from Sheet2(code) and paste it into this new Module

Also, set the used directory as "C:\Photos\" (note the ending path separator)

If it still fails then specify also which line is highlighted when error arise and you enter "Debug"

Bye

 

[cjain_560]

Thank you Anthony, the code is working perfectly. Thank you so much for your help.

Just one more thing, in order to improve this code, I'm trying to add code for a case when the ItemCode in Column A is not valid or is Blank. How can we make sure the code doesn't stop and moves on to the next value without stopping or getting an error.

1. I thought we can add a code where it skips the discrepancy and moves on to the next value or
2. Instead of showing an error, it can download the logo of the site and paste it instead of the thumbnail.

I hope you can help me here as well.

Again, Thank you so much, much appreciated. I'm still in learning stage and you have helped me learn a lot. A big thumbs up to you.

 

[Anthony47]

I suggest replacing the inner portion of the macro as follows:

            Set oObj = HTMLdoc.getElementById("thmb-01")
'>>> Modified portion
            If Not oObj Is Nothing Then
                Url2 = oObj.src
                nPicName = GetWebFile(Url2, "C:\PROVA\")       '<<< VALID PATH & "\"
                If nPicName <> 0 Then
                    Set newPic = ActiveSheet.Shapes.AddPicture(nPicName, msoFalse, msoTrue, Cells(I, 2).Left, Cells(I, 2).Top, -1, -1)
                End If
            Else
                Set newPic = ActiveSheet.Shapes.AddPicture("C:\PROVA\NotFoundPicture.jpg", msoFalse, msoTrue, Cells(I, 2).Left, Cells(I, 2).Top, -1, -1)
            End If
'<<< End Modified
        End With

In other words, when an element is not found you will insert a standard picture (NotFoundPicture.jpg; of course you will refernce to an existing picture of yours)

Bye