VBA - 私は、Webページ持っているWebページ

Question

からのInternet Explorer 11 -getテキスト： 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開くページに移動して、試してみて、 <SPAN>内のテキストのメッセージボックスを表示するには、以下のコードを使用しています、IE 11.0.9600.18639

経由Excelを持っています。

コード：

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 

をしかし、私はこの迷惑なエラーを取得悲しいかな：

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

をしてください、誰かが私が間違っているのものを私に表示することができますしてください。これは私を夢中にさせている。前もって感謝します。

Answer 1

「ウェブから取得」を使用しない場合は、このコードを使用できます。

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には、あなたが望むテキストが含まれています（私は思う）。

あなただけがRE.Pattern = "Expiry Date : (\d{2}\/\d{2}\/\d{4})"

EDITを使用することができます実際の日付を望んでいた場合は、以下のコメントを受けて
：
は、これは私がテキストファイルへのダウンロードに基づいて

EDITを有効にしているの参照です。

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します。

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