Web search using Excel VBA error and script corrections

[fotodj]

I am trying to automate the search using VBA Excel and I recently started to get the error which I can not figure out how to fix... compile error:

Script searching this website

Military Database

scramble.nl

for values from column B for example serial field value: 98-0001

Sub Scramble()

 Dim cel As Range, ms As Worksheet, dom As HTMLDocument, loopRange As Range
    Const SEARCH_URL As String = "https://www.scramble.nl/index.php?option=com_mildb&view=search"

' USAF --------------------------------------------------------------------------------------------------------------------------

    Set ms = ThisWorkbook.Worksheets("Scramble")
    Set dom = New HTMLDocument
    Set loopRange = ms.Range("B2:B" & ms.Range("B" & Rows.Count).End(xlUp).Row).SpecialCells(2)

    Application.ScreenUpdating = False

    With CreateObject("winhttp.winhttprequest.5.1")

        For Each cel In loopRange

            .Open "POST", SEARCH_URL, False
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .send "Itemid=60&af=usaf&serial=" & cel & "&sbm=Search&code=&searchtype=&unit=&cn="
            dom.body.innerHTML = .responseText
            Dim recordFields As Object

            Set recordFields = dom.querySelectorAll(".rowBord td")

            If recordFields.Length > 0 Then
                With cel
                    .Offset(, -1) = recordFields.Item(2).innerText 'Type
                    .Offset(, 2) = recordFields.Item(1).innerText 'Code
                    .Offset(, 3) = recordFields.Item(4).innerText 'Unit
                    .Offset(, 10) = recordFields.Item(3).innerText 'C/N
                    .Offset(, 11) = recordFields.Item(5).innerText 'Status
                    .Offset(, 7) = "USAF"
               End With
            End If
        Next
    End With
End Sub

I'd appreciate any help on error and further testing the script...thank you

 

[Edgar_]

Open the dialog in Tools > References and then make sure you have checked the reference to Microsoft HTML Object Library.

 

[fotodj]

@Edgar_ thank you, that took care of the error, but script itself doesn't import any data, I think they might have been some changes on the website, it use to work before....I can not find out why....

 

[Trevor G]

What if you change dom to dim as it?

 

[fotodj]

@Trevor G it will just create an syntax error....

 

[Edgar_]

I don't know how you got that URL, I was able to make the website return the results by using another method.

I went into the website and made a search, I noticed it made a few requests to their servers and I picked up a URL from there. Since searching in that website requires a cookie, I sent a simple GET request first in order to get that cookie and then I make the search using that cookie. The result is the table that you're looking for. The code looks like this:

Option Explicit

Private cookie As String

Sub Search() '<------- run this to test
    Const SEARCH_URL As String = "https://scramble.nl/database/military/usaf"
   
    Dim serial As String
    serial = Hoja12.Range("A2") ' adapt to your worksheet
   
    ' Get cookie if we don't have one
    If Len(cookie) = 0 Then
        cookie = GetCookie(SEARCH_URL)
    End If
   
    ' Get data using cookie
    Dim responseText As String
    responseText = PostSearchData(SEARCH_URL, serial)
   
    ' If data was received, process it
    If Len(responseText) > 0 Then
        ProcessResponseData responseText
    Else
        MsgBox "No results or error in fetching data."
    End If
End Sub

' Function to retrieve the cookie from the website
Function GetCookie(url As String) As String
    With CreateObject("winhttp.winhttprequest.5.1")
        .Open "GET", url, False
        .Send
        GetCookie = ExtractCookie(.getallresponseheaders)
    End With
End Function

' Function to extract the Set-Cookie value from headers
Function ExtractCookie(headers As String) As String
    Dim headersArr As Variant
    Dim line As Variant
    headersArr = Split(headers, vbCrLf)
   
    For Each line In headersArr
        If InStr(line, "Set-Cookie: ") > 0 Then
            ExtractCookie = Trim(Split(Split(line, "Set-Cookie: ")(1), ";")(0))
            Exit Function
        End If
    Next line
    ExtractCookie = "" ' Return empty string if no cookie found
End Function

' Function to send a POST request and return the response text
Function PostSearchData(url As String, serial As String) As String
    With CreateObject("winhttp.winhttprequest.5.1")
        .Open "POST", url, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Cookie", cookie
        .Send "jform%5Bserial%5D=" & serial & "&jform%5Bcode%5D=&jform%5Btype%5D=&jform%5Bunit%5D=&jform%5Bcn%5D=&submit=Submit&task=mil.search"
        PostSearchData = .responseText
    End With
End Function

' Function to process and display the response data (HTML)
Sub ProcessResponseData(responseText As String)
    Dim doc As Object
    Set doc = CreateObject("htmlfile")
    doc.body.innerHTML = responseText
   
    On Error Resume Next
    Dim tbl As Object
    Set tbl = doc.getElementsByTagName("table")(0)
    On Error GoTo 0
   
    If Not tbl Is Nothing Then
        MsgBox tbl.outerHTML
    Else
        MsgBox "No results found."
    End If
End Sub

Let me know if you have doubts.

 

[fotodj]

Very clever script, great job @Edgar_ !

I see that test data are nicely displayed in a table, going further, how can I have this search running the loop through values range in column A [Sheets("Scramble").Range("A2:A")] and in Column B, C, D get values of search results from website for "Type", "CN" and "Unit"? I really appreciate your help and chance to learn something new....

 

[Edgar_]

Range("A2:A") sounds like it could be too large. Are you sure you want to reference 1million+ cells?

I suggest using a table, if you do, then this would work:

Option Explicit

Private cookie As String, doc As Object

Sub Search() '<------- run this to test
    Const SEARCH_URL As String = "https://scramble.nl/database/military/usaf"

    Dim serial As Range
    For Each serial In [MyTable[Serial]]

        ' Get cookie if we don't have one
        If Len(cookie) = 0 Then
            cookie = GetCookie(SEARCH_URL)
        End If
       
        ' Get data using cookie
        Dim response As String
        response = PostSearchData(SEARCH_URL, serial.Value)

        Dim result As Object
        Set result = ProcessResponseData(response)
       
        If Not result Is Nothing Then
            serial.Offset(0, 1) = result(2).innerText
            serial.Offset(0, 2) = result(3).innerText
            serial.Offset(0, 3) = result(4).innerText
        Else
            serial.Offset(0, 1) = "Not found"
        End If
       
    Next serial
End Sub

' Function to retrieve the cookie from the website
Function GetCookie(url As String) As String
    With CreateObject("winhttp.winhttprequest.5.1")
        .Open "GET", url, False
        .Send
        GetCookie = ExtractCookie(.getallresponseheaders)
    End With
End Function

' Function to extract the Set-Cookie value from headers
Function ExtractCookie(headers As String) As String
    Dim headersArr As Variant
    Dim line As Variant
    headersArr = Split(headers, vbCrLf)
 
    For Each line In headersArr
        If InStr(line, "Set-Cookie: ") > 0 Then
            ExtractCookie = Trim(Split(Split(line, "Set-Cookie: ")(1), ";")(0))
            Exit Function
        End If
    Next line
    ExtractCookie = "" ' Return empty string if no cookie found
End Function

' Function to send a POST request and return the response text
Function PostSearchData(url As String, serial As String) As String
    On Error GoTo errh
    With CreateObject("winhttp.winhttprequest.5.1")
        .Open "POST", url, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Cookie", cookie
        .Send "jform%5Bserial%5D=" & serial & "&jform%5Bcode%5D=&jform%5Btype%5D=&jform%5Bunit%5D=&jform%5Bcn%5D=&submit=Submit&task=mil.search"
        PostSearchData = .responseText
    End With
errh:
    If Err.Number > 0 Then PostSearchData = ""
End Function

' Function to process and display the response data (HTML)
Function ProcessResponseData(responseText As String) As Object
    Set doc = CreateObject("htmlfile")
    doc.body.innerHTML = responseText
 
    On Error Resume Next
    Dim tbl As Object
    Set tbl = doc.getElementsByTagName("table")(0)
    On Error GoTo 0
 
    If Not tbl Is Nothing Then
        Set ProcessResponseData = tbl.getElementsByTagName("td")
    End If
End Function

I modified the Search procedure to parse the processed data and assign it to the appropriate offsets of the range being iterated. Additionally, I updated the ProcessResponseData function to process the table and return a collection of cells directly. After performing a few tests, I also added error handling to the POST request, and made the doc variable public to avoid it going out of scope within the Search sub.

A point to consider: I'm not sure how many cells you intend to query, but keep in mind that sending too many requests to a server in a short period could be interpreted as a DoS attack, potentially leading to your IP being blocked if the server has protection mechanisms in place. While it's unlikely you'll slow the server down significantly, it's something to consider.

This approach could also be converted into a User Defined Function (UDF) or set to trigger after modifying a cell in column A, which would run the script to search the website automatically. If you prefer to use your range, just modify the table reference to your desired range. However, keep in mind that this will process over a million cells, which might take some time.

Lastly, if the search result contains more than one row of data, this method currently only returns the first row. Consider handling multiple rows if needed.

Anyway, let me know what you think.

 

[fotodj]

I would like to query 20 values in column A

but when I use

For Each serial In Worksheets("Scramble").Range("A2:A21")

gives "Not found" results, is it because I have an error in range coding?

 

[fotodj]

@Edgar_
Please disregard previous post everything works perfectly, the problem was that I had blank spaces after values in column A. Thank you very much for your help!