VBA - Internet Explorer 11 -Get Text from webpage

Question

I have a webpage: https://www.brcdirectory.com/InternalSite/Site.aspx?BrcSiteCode=1832583

I want to retrieve some text from this page, from within a HTML <Span ID> .

<span id="ctl00_ContentPlaceHolder1_FormView1_GridView1_ctl02_lb_ExpiryDate">Expiry Date : 07/12/2017</span>

I have IE 11.0.9600.18639

Via Excel, I am using the below code to open IE 11, navigate to the page and want to try and display a message box of the text inside the <SPAN> .

Code:

Option Explicit  

Sub GoToWebsiteTest()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim appIE As Object
    Dim objElement As Object
    Dim objCollection As Object
    Dim i As Long, LastRow As Long, sFolder As String
    Dim sURL As String, FILE As String

    LastRow = Range("I" & Rows.Count).End(xlUp).Row
    For i = 6 To LastRow
        Set appIE = New InternetExplorerMedium

        sURL = "https://www.brcdirectory.com/InternalSite/Site.aspx?BrcSiteCode=" & Range("I392").Value
        With appIE
            .navigate sURL
            .Visible = True
        End With

        Do While appIE.Busy Or appIE.READYSTATE <> READYSTATE_COMPLETE
            DoEvents
        Loop

        Set objCollection = appIE.document.getElementById("ctl00_ContentPlaceHolder1_FormView1_GridView1_ctl02_lb_ExpiryDate")
        MsgBox Replace(objCollection.innerText, "Expiry Date : ", "")

        appIE.Quit
        Set appIE = Nothing
    Next i

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "All BRCs Succesfully Updated."
End Sub

I have tried everything! I have tried so many variations of this line where I get the error:

Do While appIE.Busy Or appIE.READYSTATE <> READYSTATE_COMPLETE

But alas I get this annoying error:

Runtime Error: -2147467259 (80004005)
Method 'Busy' of object 'IWebBrowser2' failed.

Please, please can someone show me what i am doing wrong. This is driving me crazy. Thanks in advance.

Answer 1

If you don't want to use the "get from web" you can use this code.

Sub expiry()

    Dim RE As Object
    Dim HTML As String
    Set RE = CreateObject("vbscript.regexp")
    HTML = GetHTML("https://www.brcdirectory.com/InternalSite/Site.aspx?BrcSiteCode=1832583")


    'Expiry Date : 07/12/2017
    RE.Pattern = "(Expiry Date : \d{2}\/\d{2}\/\d{4})"
    RE.Global = True
    RE.IgnoreCase = True
    Set Matches = RE.Execute(HTML)


    ExpiryDate = Matches.Item(0).submatches.Item(0)

End Sub


Function GetHTML(URL As String) As String
    Dim HTML As String
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .Send
        GetHTML = .ResponseText
    End With
End Function

ExpiryDate will contain the text you wanted (I think).

If you only wanted the actual date you can use RE.Pattern = "Expiry Date : (\\d{2}\\/\\d{2}\\/\\d{4})"

EDIT;
In response to comments below:
This is the references I have enabled

EDIT based on download to textfile.

Private Declare Function URLDownloadToFileA Lib "urlmon" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long



    Sub expiry()

        Dim RE As Object
        Dim HTML As String
        Dim MyData As String

        Set RE = CreateObject("vbscript.regexp")
        DownloadFile "https://www.brcdirectory.com/InternalSite/Site.aspx?BrcSiteCode=1832583", "C:\TEST\goog.txt"


        Open "C:\TEST\goog.txt" For Binary As #1
        HTML = Space$(LOF(1))
        Get #1, , HTML
        Close #1


        'Expiry Date : 07/12/2017
        RE.Pattern = "(Expiry Date : \d{2}\/\d{2}\/\d{4})"
        RE.Global = True
        RE.IgnoreCase = True
        Set Matches = RE.Execute(HTML)


        ExpiryDate = Matches.Item(0).submatches.Item(0)

    End Sub



    Private Function DownloadFile(URL As String, LocalFilename As String) As Boolean
         'Thanks Mentalis:)
        Dim lngRetVal As Long
        lngRetVal = URLDownloadToFileA(0, URL, LocalFilename, 0, 0)
        If lngRetVal = 0 Then DownloadFile = True
    End Function

EDIT again.

Answer 2

I managed to resolve this by using the following code:

Option Explicit
Private ieBrowser As InternetExplorer

Sub GetBRCText()
    Dim i As Long, LastRow As Long
    Dim a As Range, b As Range
    Dim strDocHTML As String, strDocHTML2 As String
    Dim dteStartTime As Date

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next

    LastRow = ThisWorkbook.ActiveSheet.Range("I" & Rows.Count).End(xlUp).Row
    Set a = Range("I6:I" & LastRow)

    'Create a browser object
    Set ieBrowser = CreateObject("internetexplorer.application")


    For Each b In a.Rows
    If Not IsEmpty(b) Then

    'Start Browsing loop
    ieBrowser.navigate "https://www.brcdirectory.com/InternalSite/Site.aspx?BrcSiteCode=" & b.Value


   dteStartTime = Now
   Do While ieBrowser.READYSTATE <> READYSTATE_COMPLETE
      If DateDiff("s", dteStartTime, Now) > 240 Then Exit Sub
   Loop

   On Error Resume Next
   strDocHTML = ieBrowser.document.getElementById("ctl00_ContentPlaceHolder1_FormView1_GridView1_ctl02_lb_ExpiryDate").innerHTML
   strDocHTML2 = ieBrowser.document.getElementById("ctl00_ContentPlaceHolder1_FormView1_GridView1_ctl02_lb_Grade").innerHTML

   b.Offset(0, 2).Value = Replace(strDocHTML, "Expiry Date : ", "")
   b.Offset(0, 1).Value = Replace(strDocHTML2, "Grade : ", "")

   End If
   Next b



   ieBrowser.Quit
   Set ieBrowser = Nothing

   Application.ScreenUpdating = True
   Application.DisplayAlerts = True


End Sub