VBA - Internet Explorer 11 -Holen Text von Webseiten

Question

Ich habe eine Webseite: https://www.brcdirectory.com/InternalSite/Site.aspx?BrcSiteCode=1832583

Ich möchte einen Text auf dieser Seite abgerufen werden, innerhalb eines HTML <Span ID>.

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

Ich habe IE 11.0.9600.18639

Via Excel, ich den Code unten bin mit auf der Seite zu öffnen 11 IE, navigieren und will in den <SPAN> ein Meldungsfeld des Textes, um zu versuchen und anzuzeigen.

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 

ich alles versucht haben! Ich habe so viele Variationen dieser Linie versuchte, wo ich den Fehler:

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

Aber ach ich diesen ärgerlichen Fehler:

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

Bitte, bitte kann mir jemand zeigen, was ich falsch mache. Das macht mich verrückt. Danke im Voraus.

Answer 1

Wenn Sie das "Get from Web" nicht verwenden möchten, können Sie diesen Code verwenden.

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 enthält den Text, den Sie wollten (glaube ich).

Wenn Sie nur das aktuelle Datum wollte man RE.Pattern = "Expiry Date : (\d{2}\/\d{2}\/\d{4})"

EDIT verwenden können;
In Reaktion auf die Kommentare unter:
Dies ist die Referenzen I

EDIT basierend auf Download Text-Datei aktiviert haben.

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 

erneut bearbeiten.

Answer 2

konnte ich dieses Problem zu beheben, indem Sie den folgenden 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