Need help to convert Internet Explorer based web scraping to XMLHTTP

Question

I am trying to speed up some intranet webscraping as well as make it more reliable. I am just learning how to implement XMLHTTP and I need some advice on converting my code from IE based scrapping to XMLHTTP.

I have 2 subs in my module that accomplishes loading up and navigating the intranet site (GetWebTable) and parsing through the data (GetOneTable) to return a table in excel. The subs are as follows:

Sub GetWebTable(sAccountNum As String)

On Error Resume Next

Dim objIE           As Object
Dim strBuffer       As String
Dim thisCol         As Integer
Dim iAcctCount      As Integer
Dim iCounter        As Integer
Dim iNextCounter    As Integer
Dim iAcctCell       As Integer
Dim thisColCustInfo As Integer
Dim iErrorCounter As Integer

    If InStr(1, sAccountNum, "-") <> 0 Then
        sAccountNum = Replace(sAccountNum, "-", "")
    End If

    If InStr(1, sAccountNum, " ") <> 0 Then
        sAccountNum = Replace(sAccountNum, " ", "")
    End If

    iErrorCounter = 1
    TRY_AGAIN:

    'Spawn Internet Explorer
        Set objIE = GetObject("new:{D5E8041D-920F-45e9-B8FB-XXXXXXX}") 
        DoEvents

        With objIE
            .Visible = False
            .Navigate "http://intranetsite.aspx"

            While .busy = True Or .readystate <> 4: DoEvents: Wend
            While .Document.readyState <> "complete": DoEvents: Wend

            .Document.getElementById("ctl00_MainContentRegion_tAcct").Value = sAcct

            While .busy = True Or .readyState <> 4: DoEvents: Wend
            While .Document.readyState <> "complete": DoEvents: Wend

            .Document.getElementById("ctl00_MainContentRegion_btnRunReport").Click

            While .busy = True Or .readyState <> 4: DoEvents: Wend
            While .Document.readyState <> "complete": DoEvents: Wend

        End With

            thisCol = 53
            thisColCustInfo = 53

        GetOneTable objIE.Document, 9, thisCol

        'Cleanup:
        objIE.Quit
        Set objIE = Nothing

    GetWebTable_Error:
    Select Case Err.Number
        Case 0
        Case Else
        Debug.Print Err.Number, Err.Description
        iErrorCounter = iErrorCounter + 1
        objIE.Quit
        Set objIE = Nothing
        If iErrorCounter > 4 Then On Error Resume Next
        GoTo TRY_AGAIN

            'Stop
    End Select
End Sub



Sub GetOneTable(varWebPageDoc, varTableNum, varColInsert)

Dim varDocElement   As Object ' the elements of the document
Dim varDocTable     As Object ' the table required
Dim varDocRow       As Object ' the rows of the table
Dim varDocCell      As Object ' the cells of the rows.
Dim Rng             As Range
Dim iCellCount      As Long
Dim iElemCount      As Long
Dim iTableCount     As Long
Dim iRowCount       As Long
Dim iRowCounter As Integer
Dim bTableEndFlag As Boolean

bTableEndFlag = False

For Each varDocElement In varWebPageDoc.all
    If varDocElement.nodeName = "TABLE" Then
        iElemCount = iElemCount + 1
    End If

    If iElemCount = varTableNum Then
        Set varDocTable = varDocElement

        iTableCount = iTableCount + 1
        iRowCount = iRowCount + 1
        Set Rng = Worksheets("Sheet1").Cells(2, varColInsert)

        For Each varDocRow In varDocTable.Rows

            For Each varDocCell In varDocRow.Cells
                If Left(varDocCell.innerText, 9) = "Total for" Then
                    bTableEndFlag = True
                    Exit For
                End If
                Rng.Value = varDocCell.innerText
                Set Rng = Rng.Offset(, 1)
                iCellCount = iCellCount + 1
            Next varDocCell

            iRowCount = iRowCount + 1
            Set Rng = Rng.Offset(1, -iCellCount)
            iCellCount = 0

        Next varDocRow

        Exit For

    End If

Next varDocElement

Set varDocElement = Nothing
Set varDocTable = Nothing
Set varDocRow = Nothing
Set varDocCell = Nothing
Set Rng = Nothing

End Sub

Any thoughts?

Need help to convert Internet Explorer based web scraping to XMLHTTP

Answers (1)

Related Questions