[FIXED] IS there any library or element in VBA which can fetch the images from ecommerce site and show in Excel

Issue

I have done a webcrapping of a website using normal VBA code after watching tutorial on youtube, which has helped me getting most of the information which I needed from ecommerce site. But, I need to fecth the images of those product as well in excel, for which I need little help from this community. Below is the code which I have written for scrapping the data. Now I need to show the images in F column adjacent to products.

Dim site_Path As String
Dim HTTPreq As New MSXML2.XMLHTTP60
Dim html As HTMLDocument
Dim url As String

url = Sheet1.Range("I3").Text

'url = "https://www.crateandbarrel.com/sale/fall-furniture-sale/1"

'send HTTP request to url

With HTTPreq
    .Open "Get", url, False
    .send
End With

response = HTTPreq.responseText

Debug.Print response

'read response html document

Set html = CreateObject("htmlfile")
html.body.innerHTML = response

r = 1
For Each divElement In html.getElementsByClassName("product-detail-description")
    r = r + 1
    Set divCollection = divElement.all
    For Each element In divCollection
        If InStr(element.className, "product-name") > 0 Then Range("A" & r).Value = element.innerText
        If element.className = "salePrice" Then Range("B" & r).Value = element.innerText
        If element.className = "regPrice" Then Range("C" & r).Value = element.innerText
        If element.className = "product-new" Then Range("D" & r).Value = element.innerText
        If element.className = "line-level-primary-short-lrg llm-spill-short" Then Range("E" & r).Value = element.innerText
        If element.className = "product-picture" Then Range("F" & r).Value = element.innerText

   Next element
Next divElement


End Sub```

Solution

Below's the solution. Though it can be optiomized further I believe. @PEH

Sub webscrape()

Dim site_Path As String
Dim HTTPreq As New MSXML2.XMLHTTP60
Dim html As HTMLDocument
Dim URL As String


URL = Sheet2.Range("N1").Text


'send HTTP request to url

With HTTPreq
    .Open "Get", URL, False
    .send
End With

response = HTTPreq.responseText

Debug.Print response

'read response html document

Set html = CreateObject("htmlfile")
html.body.innerHTML = response

r = 1
For Each divElement In html.getElementsByClassName("product-detail-description")
    r = r + 1
    Set divCollection = divElement.all
    For Each element In divCollection
        If InStr(element.className, "product-name") > 0 Then Range("A" & r).Value = element.innerText
        If element.className = "salePrice" Then Range("B" & r).Value = element.innerText
        If element.className = "regPrice" Then Range("C" & r).Value = element.innerText
        If element.className = "product-new" Then Range("D" & r).Value = element.innerText
        If element.className = "line-level-primary-short-lrg llm-spill-short" Then Range("E" & r).Value = element.innerText
        
                
   Next element
Next divElement
   
Dim productlink As Object
Set productlink = html.getElementsByClassName("product-name-link")
r = 1

    For Each Image In productlink
    r = r + 1
    Cells(r, 6).Value = Right(Image.href, 6)

    Next
    
Dim ImageCollection As Object
Set ImageCollection = html.getElementsByClassName("product-image")
r = 1

    For Each Image In ImageCollection
    r = r + 1
    Cells(r, 7).Value = Image.src

    Next

Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long

On Error Resume Next
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("$G$2:$G$1000")

'For i = 2 To Sheet2.Range("A1048576").End(xlUp).Row

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)
'OR Set xRg = Cells(i, 7)
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("$G$2:$G$1000").Select
'OR Range("G").Select.end(xldown) if not worked on running.
Next
Application.ScreenUpdating = True

    
End Sub

Answered By - Shariq Shariq