Use XML HTTP Request On Sites That Require Object Interaction - json

Question

I am working on a project to scrape information from a number of websites. I have a number of sites working with no issue, largely processing them by amending the URL to pass through the relevant criteria or by posting AJAX requests. I am fairly new to this so I am seeking some assistance.
I have come across a website where I need to interact with objects on a page in order to obtain further information. An example of this is the below site:
Example Site
If you visit the site and go to the bottom there are more brands and clicking "view" will display additional products. The HTML for these is only returned once clicked.
With other sites I have sourced information from I have used the below approach. Is there a way to process the page via the XML HTTP Method after a page object action has been performed?
Any help would be greatly appreciated. At the moment I am assuming I will have to stick to scraping such sites using an Internet Explorer object.
Option Explicit
Public Sub sbKF()
Dim conn As ADODB.Connection
Dim rsIn As ADODB.Recordset
Dim HTMLDoc As HTMLDocument
Dim strUrl As String
Dim strPost As String
Set conn = CurrentProject.Connection
Set rsIn = New ADODB.Recordset
Set HTMLDoc = New MSHTML.HTMLDocument
rsIn.Open pcstrInput, conn, adOpenStatic, adLockReadOnly
rsIn.MoveLast: rsIn.MoveFirst
Do While Not rsIn.EOF
' Create the URL and Post submission for input size.
strUrl = "http://www.[Site].com"
strPost = "Stage=2&sop=TyreSize&ssq=1&vnp=&vmk=&vch=&vmo=&drd="
' Return the Document body results
HTMLDoc.body.innerHTML = fnPostXmlHttp(strUrl, strPost)
rsIn.MoveNext
Loop
End Sub
Public Function fnPostXmlHttp(ByVal strUrl As String, ByVal strScript As String)
Dim XMLHttpRequest As Object
Dim strOut As String
Set XMLHttpRequest = CreateObject("MSXML2.XMLHTTP")
XMLHttpRequest.Open "POST", strUrl, False
XMLHttpRequest.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
XMLHttpRequest.send (strScript)
While XMLHttpRequest.ReadyState <> 4
DoEvents
Wend
fnPostXmlHttp = XMLHttpRequest.responseText
End Function

Answer 1

If you take a look at www.blackcircles.com HTML response, you will see the javascript snippet:
...
var newTyresActionUrl;
var lookupAddress;
$(document).ready(function () {
newTyresActionUrl = new BC.classes.productV6SearchPage('https://www.blackcircles.com/order/tyres',
{"Error":false,"VariantFitments":[{"Name":"All Season","VariantType":11,"SeasonalType":true,"TruckType":false,"FriendlyName":"allseason","Count":17,
...
"TakeoverCss":"\u003clink id=\"brandtakeover-css\" rel=\u0027stylesheet\u0027 type=\u0027text/css\u0027 href=\u0027/templates/bcstyles/css/goodyear-effgrip-perf.css\u0027\u003e"},
"Width",
"Profile",
"Rim",
"Speed",
"Method",
true,
""
);
addToBasket = new BC.classes.addtobasket('https://www.blackcircles.com/order/tyres', "order", '/truck/garages');
...
Actually the portion within curly braces represents a JSON object containing all displayed on the webpage data. So you can extract that JSON string from HTML content by Instr(), parse it, convert to arrays and output to the worksheet, as shown in the example code below. Import JSON.bas module into the VBA project for JSON processing.
Option Explicit
Sub Test_blackcircles()
Dim sResp As String
Dim vJSON As Variant
Dim sState As String
Dim i As Long
Dim vItem
Dim aData()
Dim aHeader()
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.blackcircles.com/order/tyres/search?width=205&profile=55&rim=R16&speed=V&vehicle-make=&postcode=&delivery=1&findTyre=", False
.send
sResp = .responseText
End With
sResp = getFragment(sResp, "new BC.classes.productV6SearchPage", "new BC.classes.addtobasket")
sResp = getFragment(sResp, "{", "}")
sResp = "{" & sResp & "}"
JSON.Parse sResp, vJSON, sState
i = 1
With Sheets(1)
.Cells.Delete
.Cells.WrapText = False
For Each vItem In Array( _
"Manufacturers", _
"CarManufacturers", _
"All", _
"Deals", _
"Best", _
"Rest", _
"SearchParams" _
)
.Cells(i, 1).Value = vItem
JSON.ToArray vJSON(vItem), aData, aHeader
OutputArray .Cells(i + 2, 1), aHeader
Output2DArray .Cells(i + 3, 1), aData
.Columns.AutoFit
i = i + UBound(aData, 1) + 5
Next
End With
End Sub
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Function getFragment( _
sourceText As String, _
startPattern As String, _
endPattern As String _
) As String
Dim startPos
startPos = InStr(sourceText, startPattern)
If startPos = 0 Then Exit Function
Dim partText
partText = Mid(sourceText, startPos + Len(startPattern))
Dim endPos
endPos = InStrRev(partText, endPattern)
If endPos = 0 Then Exit Function
getFragment = Left(partText, endPos - 1)
End Function
BTW, the similar approach applied in other answers.