VBA – Internet Explorer 11 – 从网页获取文本

我有一个网页： https : //www.brcdirectory.com/InternalSite/Site.aspx? BrcSiteCode =1832583

我想从这个页面中检索一些文本，从一个HTML <Span ID> 。

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

我有IE 11.0.9600.18639

通过Excel，我使用下面的代码打开IE 11，导航到页面，并且想要尝试在<SPAN>中显示文本的消息框。

码：

 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 

我已经尝试了一切！ 我已经尝试过这么多的变化，我得到这个错误：

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

但是，唉，我得到这个恼人的错误：

运行时错误：-2147467259（80004005）
对象'IWebBrowser2'的方法'繁忙'失败。

请，请有人告诉我我做错了什么。 这真让我抓狂。 提前致谢。

Answer 1

如果你不想使用“get from web”，你可以使用这个代码。

 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将包含你想要的文本（我认为）。

如果您只想要实际的date，您可以使用RE.Pattern = "Expiry Date : (\d{2}\/\d{2}\/\d{4})"

编辑;
针对以下评论：
这是我启用的参考

基于下载到文本文件编辑。

 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 

再次编辑。

Answer 2

我设法解决这个通过使用下面的代码：

 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