VBA - Internet Explorer 11 -Get Text from webpage - html

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