Insert picture from a webpageURL into excel using macros

cjain_560

New Member
Joined
Mar 10, 2021
Messages
10
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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.
VBA Code:
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

New Member
Joined
Mar 10, 2021
Messages
10
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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.

VBA Code:
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
 

Attachments

  • code 2.PNG
    code 2.PNG
    127 KB · Views: 5

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

cjain_560

New Member
Joined
Mar 10, 2021
Messages
10
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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

Well-known Member
Joined
Mar 29, 2006
Messages
2,237
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

New Member
Joined
Mar 10, 2021
Messages
10
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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

Well-known Member
Joined
Mar 29, 2006
Messages
2,237
I suggest replacing the inner portion of the macro as follows:
VBA Code:
            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
 

Forum statistics

Threads
1,141,476
Messages
5,706,604
Members
421,460
Latest member
Taamrak

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top