Data Extraction From Website

Option Explicit

'Needs references to Microsoft Internet Controls and Microsoft HTML Object Library.  Set these in Tools - References in the VB Editor.


Public Sub AZMD_Name_Search()

    Dim IE As InternetExplorer
    Dim URL As String
    Dim HTMLdoc As HTMLDocument
    Dim lastName As String, firstName As String
    
    URL = "http://azmd.gov/glsuiteweb/clients/azbom/public/WebVerificationSearch.aspx"
    lastName = "Smith"
    firstName = "Alison"
    
    Set IE = New InternetExplorer
    
    With IE
        .navigate URL
        .Visible = True
    
        'Wait for initial page to load
    
        While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
    
        Set HTMLdoc = .document
    End With
    
    'Populate form fields
    
    '< input name="tbLastName" type="text" value="alison" id="tbLastName" style="width:180px;" />
    '< input name="tbFirstName" type="text" value="smith" id="tbFirstName" style="width:180px;" />
    
    HTMLdoc.all.tbLastName.Value = lastName
    HTMLdoc.all.tbFirstName.Value = firstName
    
    'Click the Name Search button
    '< input type="submit" name="btnName" value="Name Search"
    'o_nclick="javascript:WebForm_DoPostBackWithOptions(new WebForm_PostBackOptions("btnName", "",
    'true, "", "", false, false))" id="btnName" style="width:121px;" />
    
    HTMLdoc.all.btnName.Click
        
    With IE
        'Wait for new page to load
        While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
        
        Sheet1.Cells.ClearContents
        
        If .LocationName = "Profile" Then
            
            'Profile found - extract data
            
            Extract_Tables HTMLdoc, Sheet1.Range("A1")
        
        ElseIf .LocationName = "Licensee Search" Then
        
            'Original page, so no results found
            '< textarea name="tbErrorName" rows="2" cols="20" id="tbErrorName" style="color:Red;background-color:White;height:42px;width:100%;">No doctors found with those specifications.< /textarea>< /td>

            Sheet1.Range("A1").Value = HTMLdoc.all.tbErrorName.innerText

        End If
        
    End With
    
End Sub


Private Sub Extract_Tables(document As HTMLDocument, destination As Range)
    
    'Extract data in rows and columns from all HTML tables and put the data starting at the specified destination
    'This is similar to how a Web Query formats the retrieved data
 
    Dim tables As IHTMLElementCollection
    Dim table As HTMLTable
    Dim row As HTMLTableRow, cell As HTMLTableCell
    Dim rowOffset As Long, colOffset As Long
    Dim lines As Variant
    Dim i As Integer
    
    Set tables = document.getElementsByTagName("TABLE")
 
    rowOffset = 0
    For Each table In tables
        For Each row In table.Rows
            colOffset = 0
            For Each cell In row.Cells
                'Only extract cell text if this cell has no nested < td> elements, meaning it is the innermost cell element
                If cell.all.tags("TD").Length = 0 Then
                    'Put each HTML < br> 'line' in separate rows
                    lines = Split(cell.innerText, vbCrLf)
                    For i = 0 To UBound(lines)
                        destination.Offset(rowOffset + i, colOffset).Value = lines(i)
                    Next
                    colOffset = colOffset + 1
                End If
            Next
            'Increment row by the number of rows just written to
            rowOffset = rowOffset + i
        Next
    Next
         
End Sub

IE As InternetExplorer