VBA Javascript Pop-Up Window

Question

I am trying to get some data from a website but the HTML that needs parsing is quite complex to my level and knowledge, however, the website has a nice feature he will arrange that Data in a table. The issue is that the creation of that table is something like Table Format which pops a new chrome window. I have tried the Event Listeners in Chrome's developer tools but no success. Is there any way to get that table?
So far I have the following code:

Option Explicit 
Public Sub IndianMoU()

    Dim strPost As String, d As String, s As String, startDate As String, endDate As String
    Dim http As Object

    startDate = "01.08.2019" 'Replace(UserForm1.TextBox1, "/", ".")
    endDate = "31.08.2019" '"Replace(UserForm1.TextBox2, "/", ".")

    Const Boundary As String = "----WebKitFormBoundary11XcIMf4gNidMvY2"
    Set http = CreateObject("MSXML2.XMLHTTP")
    'Get authentication ticket:

    'Build source form for login
    d = "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""flag1""" & vbCrLf & vbCrLf
    d = d & "0"
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""HidFlag""" & vbCrLf & vbCrLf
    d = d & "Agreed"
    d = d & vbCrLf & "--" & Boundary & "--" & vbCrLf

    With http
        .Open "POST", "http://www.iomou.org/php/InspData.php", False
        .setRequestHeader "Content-Type", "multipart/form-data; boundary=----WebKitFormBoundary11XcIMf4gNidMvY2"
        .send d
        's = .responseText
    End With

    'Build source form for inpsections
    d = "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""FindInspAction""" & vbCrLf & vbCrLf
    d = d & "Find"
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""StartOffset""" & vbCrLf & vbCrLf
    d = d & "1"
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""flag1""" & vbCrLf & vbCrLf
    d = d & "0"
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""txtStartDate""" & vbCrLf & vbCrLf
    d = d & startDate
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""txtEndDate""" & vbCrLf & vbCrLf
    d = d & endDate
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""opt_txtISC""" & vbCrLf & vbCrLf
    d = d & "I"
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""txtISC""" & vbCrLf & vbCrLf
    d = d & ""
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""opt_lstFCS""" & vbCrLf & vbCrLf
    d = d & "F"
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""lstFCS""" & vbCrLf & vbCrLf
    d = d & "PT"
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""chkDet""" & vbCrLf & vbCrLf
    d = d & "All"
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""InspType""" & vbCrLf & vbCrLf
    d = d & "All"
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""lstAuth""" & vbCrLf & vbCrLf
    d = d & "000"
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""SortOrder""" & vbCrLf & vbCrLf
    d = d & "NoSort"
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""AscDsc""" & vbCrLf & vbCrLf
    d = d & "Desc"
    d = d & vbCrLf & "--" & Boundary & vbCrLf
    d = d & "Content-Disposition: form-data; name=""lstLimit""" & vbCrLf & vbCrLf
    d = d & "600"
    d = d & vbCrLf & "--" & Boundary & "--" & vbCrLf

    With http
        .Open "POST", "http://www.iomou.org/php/InspData.php", False
        .setRequestHeader "Content-Type", "multipart/form-data; boundary=----WebKitFormBoundary11XcIMf4gNidMvY2"
        .send d
        s = .responseText
    End With
    Debug.Print s  
End Sub

Thank you in advance.
Eduardo

QHarr · Accepted Answer

As you have discovered (and I recommend you post as answer) you can mimic what the page does in terms of an initial POST xhr update via multipart/form-data that at the back end runs a SQL query to generate the required results. You then send a subsequent GET xhr to the tableFormat php URI. That is efficient and, because the IOMOU databases are queried in the background, you get the additional info from the latest inspection regime e.g. the matrix calculation output for SRP and the decisions made regarding whether a given deficiency is cause for detention.

Alternate:

Interestingly, you can just send two GETs where the first is a query string that still kicks off the back end preparation of data; using serverXMLHTTP I can then issue a second GET and grab the results.

Example output row

VBA

Option Explicit

Public Sub GetInspectionResults()
    Dim html As MSHTML.HTMLDocument, clipboard As Object

    Set html = New MSHTML.HTMLDocument: 
    Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

    With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "GET", "http://www.iomou.org/php/InspData.php?lstLimit=1000&StartOffset=1&FindInspAction=Find&txtStartDate=04.12.2018&txtEndDate=12.12.2019&opt_txtISC=I&txtISC=&opt_lstFCS=F&lstFCS=PT&lstAuth=000&chkDet=All&InspType=All&SortOrder=NoSort&AscDsc=Desc", False
        .send
        .Open "GET", "http://www.iomou.org/php/TableFormat.php", False
        .send
        html.body.innerHTML = .responseText
    End With

    clipboard.SetText html.querySelector("#tblDiaplayResult").outerHTML
    clipboard.PutInClipboard

    ThisWorkbook.Worksheets("Test").Range("A1").PasteSpecial  
End Sub

The ugly way:

In case you were interested in using the query string url construct, without the php uri call, then another way is as shown below. It is not particularly robust (e.g. the long chained methods), so I would only review it to gain some insight into the available methods for DOM walking, and how to shape results into a specified format i.e. the output table you see on the page when asking for tabular format.

I have put notes in the code but overall I am:

Altering the querystring limit parameter to get 1000 results at a time to reduce the number of requests. You may be able to go higher than this. I use set startDate, endDate and flag parameters. There are others you could set. I use some defaults. Depending on the number of deficiency links you can have between 1 and n + 1 requests where n is the number of results. Compare that to your two requests.
Issuing an initial request and determining the total number of results. Issuing more requests, in batches of 1000, if more results than 1000 are available.
With each request I am grabbing two nodeLists initially. One, detentionReleaseDates, is a nodeList containing all the detention/release date info at odd and even indices respectively. The other, loopNodes, contains the other nodes in the individual inspection tables. In the latter, items repeat at step 17 e.g. ship name recurs every 17th node. A little maths allows me to use a single loop to access both these nodeLists at the same time and populate an array, resultSet, with this info.
I use two arrays, inputPositions and outputPositions, to handle the mapping of indices in loopNodes to columns in output. There are 24 columuns in output. 16 of these columns are populated from nodes in the 17 wide loop of loopNodes.length. A couple of indices are left blank due to info not available with this approach. The detentionDate/releaseDate info comes from the other nodeList with some rules applied to determine final output. Sr. No. is auto-numbering of rows (inspections). To get deficiency info the associated url, if applicable, is extracted and a new request made to that url to get the two tables which provide the No. of Rectified Deficiencies Of No. of Deficiencies and Deficiency Code and Name field values.
During the loop I use a helper function, GetLastRow, to find the last occupied row on the page so I can write the current resultSet array out to the next available row.

Due to the width of the mapping visual I include a gif of the process to generate the correct output from the given input:

It is a little slow to give you time to inspect.

VBA:

Option Explicit

'MaxRequests <= n+1
Public Sub GetShipInspectionResults()

    Const LIMIT As Long = 1000
    Const FLAG As String = "PT"

    Dim startDate As String, endDate As String, xhr As Object
    Dim ws As Worksheet, re As Object, html As MSHTML.HTMLDocument

    startDate = "04.12.2018"
    endDate = "12.12.2019"
    Set xhr = CreateObject("MSXML2.XMLHTTP")
    Set html = New MSHTML.HTMLDocument
    Set re = CreateObject("VBScript.RegExp")
    Set ws = ThisWorkbook.Worksheets("Results")

    ClearSheet ws

    Dim url As String, numberOfResults As Long, numberOfPages As Long, page As Long

    url = GetUrl(startDate, endDate, LIMIT, FLAG, 1)

    UpdatePage html, xhr, url

    numberOfResults = GetCount(re, html.querySelector(".generalinformation b").innerText, "Total\s+(\d+)\s+records")(0)

    numberOfPages = Application.RoundUp(numberOfResults / LIMIT, 0)

    Dim totalRows As Long, headers()

    headers = GetHeaders
    ws.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers

    For page = 1 To numberOfPages
        If page > 1 Then
            url = GetUrl(startDate, endDate, LIMIT, FLAG, page)
            UpdatePage html, xhr, url
        End If

        totalRows = GetNumberOfTableRows(re, html)

        Dim resultSet(), valuesForTable()
        ReDim resultSet(1 To totalRows, 1 To UBound(headers) + 1)

        valuesForTable = GetResults(html, resultSet, xhr)

        With ws
            .Cells(IIf(page = 1, 2, GetLastRow(ws) + 1), 1).Resize(UBound(valuesForTable, 1), UBound(valuesForTable, 2)) = valuesForTable
        End With
    Next

End Sub

Public Function GetResults(ByVal html As MSHTML.HTMLDocument, ByRef resultSet(), ByVal xhr As Object) As Variant
    'Populate an array with current page results. There are two nodeLists used. 1 for detention release dates and 1 for _
    pretty much all the other nodeLists. loopNodes has most of the info with items e.g.ship name appearing at step 17. _
    detentionReleaseDates is shorter but has its length has the same common divisor of 17 so a little maths means only one _
    loop required to populate array from both lists.

    '  "Sr. No.", "IMO Number", "Call Sign", "Gross Tonnage", _
    '  "Deadweight", "IMO Company No.", "Particulars of Company", _
    '  "Ship Name", "Flag", "Date Keel Laid", "Ship Type", "Classification Society", _
    '  "Place of Inspection", "Date of Inspection", "Type of Inspection", _
    '  "Detained", "Date of Detention", "Date of Release", "Deficiencies", _
    '  "No. of Rectified Deficiencies Of No. of Deficiencies", "Deficiency Code and Name", _
    '  "Detainable Deficiency", "Inspecting Authority", "SRP Value"

    '"Sr. No." Auto-numbered

    Dim detentionReleaseDates As Object, loopNodes As Object, html2 As MSHTML.HTMLDocument

    Set html2 = New MSHTML.HTMLDocument
    Set detentionReleaseDates = html.querySelectorAll("[border='1'] tr + tr td") 'loop step 2. Position odd detention, even release
    Set loopNodes = html.querySelectorAll("td  font > strong")

    Dim inputPositions(), outputPositions(), i As Long, j As Long

    inputPositions = Array(0, 1, 2, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16) 'map position in nodeList (step block of 17) to desired output column.
    outputPositions = Array(8, 2, 3, 4, 5, 9, 10, 11, 12, 13, 14, 15, 6, 7, 16, 23)

    Dim requestUrls(), k As Long, r As Long, releaseDate As String, detentionDate As String

    requestUrls() = GetDeficiencyLinks(html)

    For i = 0 To loopNodes.Length - 1 Step 17    '0,17,34,51,68,.....1598,1615
        DoEvents
        r = r + 1
        resultSet(r, 1) = i / 17 + 1
        detentionDate = detentionReleaseDates.Item(2 * i / 34).innerText
        releaseDate = detentionReleaseDates.Item(2 * i / 34 + 1).innerText

        If releaseDate = "00.00.0000" Then releaseDate = "Under Detention" 'Apply handling ruled. WIP.

        resultSet(r, 17) = IIf(detentionDate = vbNullString And releaseDate = vbNullString, "Not Applicable", detentionDate)
        resultSet(r, 18) = IIf(detentionDate = vbNullString And releaseDate = vbNullString, "Not Applicable", releaseDate)

        For j = LBound(inputPositions) To UBound(inputPositions) ' use IO column mappings to determine where current node innerText goes
            k = inputPositions(j)
            resultSet(r, outputPositions(j)) = IIf(j = 0, loopNodes.Item(i).LastChild.innerText, loopNodes.Item(i + k).innerText)
        Next

        Dim url As String, tables As Object, m As Long

        url = requestUrls(i / 17 + 1)

        'handle according to whether "No deficiencies". Where additional request made then need loop with row increment to add deficiency rows.
        If url <> "No Deficiencies" Then
            UpdatePage html2, xhr, url 'make request for deficiencies tables to populate output columns 20-21
            Set tables = html2.querySelectorAll("#tbldisplay")

            resultSet(r, 20) = tables.Item(0).Rows(1).Children(1).innerText & " Of " & tables.Item(0).Rows(1).FirstChild.innerText

            For m = 1 To tables.Item(1).Rows.Length - 2 ' add in rows per deficiency
                resultSet(r, 21) = tables.Item(1).Rows(m).Children(1).innerText & ":" & tables.Item(1).Rows(m).Children(2).innerText
                r = r + 1
            Next
            Set tables = Nothing
        Else
            resultSet(r, 20) = "0 Of 0"
        End If
    Next
    GetResults = resultSet
End Function

Public Function GetDeficiencyLinks(ByVal html As MSHTML.HTMLDocument) As Variant

    Dim results(), nodes As Object, i As Long, url As String

    Set nodes = html.querySelectorAll("[bgcolor='#FFDBE7']") 'choose a node that also account for No deficiencies

    ReDim results(1 To nodes.Length)

    For i = 0 To nodes.Length - 1
        url = "No Deficiencies"

        On Error Resume Next                     'fragile walk to `a` tag to get href. This could be replaced with using a surrogate HTMLDocument variable and then html3.body.innerHTML = nodes.Item(i).outerHTML: url = html3.querySelector("a").href
        url = Replace$(nodes.Item(i).LastChild.LastChild.LastChild.LastChild.FirstChild.href, "about:", "http://www.iomou.org/php/")
        On Error GoTo 0

        results(i + 1) = url
    Next
    GetDeficiencyLinks = results
End Function

Public Function GetNumberOfTableRows(ByVal re As Object, ByVal html As MSHTML.HTMLDocument) As Long

    Dim totalNumber As Long, nodes As Object, i As Long

    Set nodes = html.querySelectorAll("[bgcolor='#FFDBE7']")

    For i = 0 To nodes.Length - 1

        Dim searchString As String, matches()

        searchString = nodes.Item(i).LastChild.LastChild.innerText
        matches = GetCount(re, searchString, "(No Deficiencies)|(\d+)")

        If UBound(matches) = 0 Then
            totalNumber = totalNumber + matches(0)
        Else
            totalNumber = totalNumber + matches(1)
        End If
    Next
    GetNumberOfTableRows = totalNumber
End Function

Public Function GetCount(ByVal re As Object, ByVal s As String, ByVal p As String) As Variant

    Dim matches As Object, results()
    'Should probably use .test wrapper and handle no matches. Below might benefit from being split out into different functions to handle different cases.
    With re
        .Global = True
        .MultiLine = True
        .Pattern = p
        Set matches = .Execute(s)
        ReDim results(0)
        If matches.Count = 1 And InStr(s, "Rectified") > 0 Then
            results(0) = matches(0)
        ElseIf matches.Count = 1 And InStr(s, "No Deficiencies") > 0 Then
            results(0) = 1
        ElseIf matches.Count = 1 Then
            results(0) = matches(0).submatches(0)
        Else
            ReDim results(1)
            results = Array(matches(0), matches(1))
        End If
    End With
    GetCount = results
End Function

Public Sub UpdatePage(ByVal html As MSHTML.HTMLDocument, ByVal xhr As Object, ByVal url As String)
    With xhr
        .Open "GET", url, False
        .send
        html.body.innerHTML = .responseText
    End With
End Sub

Public Function GetUrl(ByVal startDate As String, ByVal endDate As String, ByVal LIMIT As Long, ByVal FLAG As String, ByVal pageNumber As Long) As String
    'Params: lstFCS = Flag;txtStartDate = startDate; txtEndDate = endDate. Add other params if required
    'Example: http://www.iomou.org/php/InspData.php?lstLimit=1000&StartOffset=1&FindInspAction=Find&txtStartDate=04.12.2018&txtEndDate=12.12.2019&opt_txtISC=I&txtISC=&opt_lstFCS=F&lstFCS=PT&lstAuth=000&chkDet=All&InspType=All&SortOrder=NoSort&AscDsc=Desc
    Dim url As String

    url = "http://www.iomou.org/php/InspData.php?lstLimit=" & LIMIT & "&StartOffset=" & pageNumber
    url = url & "&FindInspAction=Find&txtStartDate=" & startDate & "&txtEndDate=" & endDate
    url = url & "&opt_txtISC=I&txtISC=&opt_lstFCS=F&lstFCS=" & FLAG & "&lstAuth=000&chkDet=All&InspType=All&SortOrder=NoSort&AscDsc=Desc"

    GetUrl = url
End Function

Private Function GetLastRow(ByVal ws As Worksheet) As Long

    GetLastRow = ws.Cells.Find(What:="*", After:=ws.Range("A1"), _
                               LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                               SearchDirection:=xlPrevious, MatchCase:=False).Row

End Function

Public Function GetHeaders() As Variant

    Dim headers()

    headers = Array("Sr. No.", "IMO Number", "Call Sign", "Gross Tonnage", _
                    "Deadweight", "IMO Company No.", "Particulars of Company", _
                    "Ship Name", "Flag", "Date Keel Laid", "Ship Type", "Classification Society", _
                    "Place of Inspection", "Date of Inspection", "Type of Inspection", _
                    "Detained", "Date of Detention", "Date of Release", "Deficiencies", _
                    "No. of Rectified Deficiencies Of No. of Deficiencies", "Deficiency Code and Name", _
                    "Detainable Deficiency", "Inspecting Authority", "SRP Value")
    GetHeaders = headers
End Function

Public Sub ClearSheet(ByVal ws As Worksheet)
    With ws.Cells
        .ClearContents
        .ClearFormats
    End With
End Sub

References (VBE>Tools>References):

Microsoft HTML Object Library

Reading:

VBA Javascript Pop-Up Window

Answers (2)

Related Questions