VBA對象變量或與塊變量未設置錯誤 - 網頁抓取

Question

，所以我寫一些VBA代碼步驟通過網站，我不斷收到「對象變量或與塊變量未設置錯誤」我通常可以通過以下步驟代碼沒有錯誤，這導致我相信這是一個時間問題。我用wait語句加載了這段代碼，仍然會出現這個錯誤。有什麼想法嗎？我在做一些瘋狂的事情嗎？

Sub Do_Work_Son() 


Dim IE As InternetExplorer 
Dim doc As HTMLDocument 
Dim plnSelect As HTMLSelectElement 'this selects the plan 
Dim adrInput As HTMLInputElement 'this selects the address 
Dim dirSelect As HTMLSelectElement 'this selects the distance 
Dim strSQL As String 
Dim LString As String 
Dim LArray() As String 

strSQL = "http://avmed.prismisp.com/?tab=doctor" 
Set IE = CreateObject("InternetExplorer.Application") 

With IE 
    .Visible = True 
    .navigate strSQL 
    Do Until .readyState = READYSTATE_COMPLETE: DoEvents: Loop 
     Application.Wait (Now + TimeValue("0:00:5")) 

Set doc = IE.document 

     'Call WaitBrowser(IE) 

     '----------------------------- 
     '--Start Page Select Criteria-- 
     '----------------------------- 

     Set plnSelect = doc.getElementsByClassName("full jqSelectPlan")(0) 
     plnSelect.selectedIndex = 1 

     Set adrInput = doc.getElementsByClassName("address-type-ahead enteredText ac_input defaultText")(0) 
     adrInput.Value = "32258" 'this is where we will link to zip code table 

     Set dirSelect = doc.getElementsByName("Proximity")(0) 
     dirSelect.selectedIndex = 0 


     doc.getElementsByClassName("button large")(0).click 'this submits the initial page 
     '------------------------------------------------------ 
     'Call WaitBrowser(IE) 
     Application.Wait (Now + TimeValue("0:00:03")) 


     Debug.Print (doc.getElementsByClassName("profileDetails")(0).innerText) 


     LString = doc.getElementsByClassName("profileDetails")(0).innerText 
     LArray = Split(LString, vbCrLf) 

     Debug.Print (LArray(0)) 


     Application.Wait (Now + TimeValue("0:00:2")) 

     Sheet1.Range("A1") = LArray(0) 
     Sheet1.Range("B1") = LArray(2) 
     Sheet1.Range("C1") = LArray(3) 
     Sheet1.Range("D1") = LArray(4) 
     Sheet1.Range("E1") = LArray(5) 
     Sheet1.Range("F1") = LArray(6) 

    End With 

End Sub 

Answer 1

您對本站有開始等待循環而不是按下按鈕 - 你只是有一個任意時間設置 - 不代碼在這裏拋出一個錯誤？

我可以recommened使用MSXML2.ServerXMLHTTP60對象發送GET/POST請求，然後解析HTML的響應，而不是自動化的Internet Explorer。

通過發送同步方式的請求會等待該請求是運行代碼的下一部分意味着你不必做「等待循環」或設置隨機時間結果之前完全完成。

我知道這是不是一個真正的答案，你的個人問題，但是這可能讓你開始：

Sub do_rework_son() 
Dim oHTTP As MSXML2.ServerXMLHTTP60 
Dim URL As String 
Dim myHTMLresult As String 
Dim zipCODE As String 
Dim myREQUEST As String 

Set oHTTP = New MSXML2.ServerXMLHTTP60 
URL = "http://avmed.prismisp.com/Search" 
zipCODE = "32258" 
myREQUEST = "SearchType=ByProvider&ProviderType=Provider&Plan=1&City=&County=&State=&Zip=&Address=" & zipCODE & "&Proximity=5&PrimaryCareProvider=true&Name=" 

oHTTP.Open "POST", URL, False 
oHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" 
oHTTP.send (myREQUEST) 

URL = "http://avmed.prismisp.com/ResetFilters" 
oHTTP.Open "POST", URL, False 
oHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" 
oHTTP.send (myREQUEST) 

oHTTP.Open "GET", "http://avmed.prismisp.com/SearchResults?PageRequested=1", False 
oHTTP.send 

myHTMLresult = oHTTP.responseText 

End sub 

這個網站是一個有點滑稽和要求相同的信息的重新提交給第一次搜索遵循（請注意前兩個POST請求的URL差異 - 是我可以訪問搜索結果的唯一方法）。

一旦搜索已經comitted的ohttp連接仍然活着，你可以使用一個簡單的GET請求（其依靠的只是URL - 沒有身體的字符串請求）。

GET請求可以瀏覽結果頁面（根據需要多次更改URL爲pagerequested = xyz頁面，只需通過簡單的循環或其他方式重複這兩個GET請求行即可瀏覽所有頁面）。

要獲得環即結果頁面數量的限制，他們是附近的HTML響應的底部。

此代碼將導航到該網站，提交表單，並且可以在「myREQUEST」字符串中替換表單中的各個部分（正如我在這裏用zipCODE所做的那樣，這是一個變量，您可以更改x的數量次並重新提交代碼循環或其他）。這一切都是在沒有Internet Explorer的背景下完成的，並且完全否定使用任何WAIT功能。

爲了解析的結果，你可以看到文本字符串響應的字符串操作或加載到一個html文件的響應，你可以使用getelementsbyID等

這裏有一個基本的「字符串只有」解析器，我爲創建工作就像我在註釋中（注意找到字符串，其中包括引號）

Sub parse_my_example_string() 

Dim string_to_parse As String 
Dim extracted_info As String 

string_to_parse = "<spec tag>Woah!</spec tag><class='this'>This is my result!</class><p>Chicken</p>" 

extracted_info = parseResult(string_to_parse, "<class='this'>", "</class>") 
MsgBox extracted_info 

extracted_info = parseResult(string_to_parse, "<spec tag>", "<") 
MsgBox extracted_info 

End Sub 

Function parseResult(ByRef resStr As String, ByRef schStr As String, ByRef endStr As String) 
Dim t1 As Integer: Dim t2 As Integer: Dim t3 As Integer 
    If InStr(1, resStr, schStr, vbBinaryCompare) > 0 Then 
    t1 = InStr(1, resStr, schStr, vbBinaryCompare) + Len(schStr) 
    t2 = InStr(t1, resStr, endStr, vbBinaryCompare) 
    t3 = t2 - t1 
    parseResult = Mid(resStr, t1, t3) 
    End If 
End Function 

，這種做法很可能在許多程序員皺起了眉頭，但我發現它很適合我的工作，特別是當XML沒有明顯的理由，dom文檔讓Excel變得非常糟糕！

Answer 2

我在這裏看到一些問題。

一個是循環等待就緒狀態是完整的推移和出於某種原因。我會採取這條線

Do Until .readyState = READYSTATE_COMPLETE: DoEvents: Loop 

因爲我不認爲這是必要的。

你沒有設置Sheet1任何東西，我懷疑你的代碼實際上是在拋出一個錯誤。試試這個

Set Sh1 = Worksheets("Sheet1") 

並使用新的參考Sh1來指代工作表。

你沒有這個陣列

LArray = Split(LString, vbCrLf) 

也許你永遠不知道你有多少元素在7個元素。在這種情況下，我會做這個

For i = LBound(LArray) to UBound(LArray) 
    Sh1.Cells(1, i+1) = LArray(i) 
Next i 

，而不是

這裏是我的代碼完成上述所有的變化：

Sub Do_Work_Son() 

Dim strSQL As String 
Dim LString As String 
Dim LArray() As String 

strSQL = "http://avmed.prismisp.com/?tab=doctor" 
Set IE = CreateObject("InternetExplorer.Application") 

With IE 
    .Visible = True 
    .navigate strSQL 
    'Do Until .readyState = READYSTATE_COMPLETE: DoEvents: Loop 
    Application.Wait (Now + TimeValue("0:00:10")) 

Set doc = IE.document 

    'Call WaitBrowser(IE) 

    '----------------------------- 
    '--Start Page Select Criteria-- 
    '----------------------------- 

    Set plnSelect = doc.getElementsByClassName("full jqSelectPlan")(0) 
    plnSelect.selectedIndex = 1 

    Set adrInput = doc.getElementsByClassName("address-type-ahead enteredText ac_input defaultText")(0) 
    adrInput.Value = "32258" 'this is where we will link to zip code table 

    Set dirSelect = doc.getElementsByName("Proximity")(0) 
    dirSelect.selectedIndex = 0 


    doc.getElementsByClassName("button large")(0).Click 'this submits the initial page 
    '------------------------------------------------------ 
    'Call WaitBrowser(IE) 
    Application.Wait (Now + TimeValue("0:00:03")) 



    LString = doc.getElementsByClassName("profileDetails")(0).innerText 
    LArray = Split(LString, vbCrLf) 

    Application.Wait (Now + TimeValue("0:00:02")) 

    Set Sh1 = Worksheets("Sheet1") 

    For i = LBound(LArray) To UBound(LArray) 
     Sh1.Cells(1, i + 1) = LArray(i) 
    Next i 

    End With 

End Sub 

你會發現我加了一點您的頁面加載時間比以前多一點。 5秒可能不夠。如果10不夠，增加更多，但這似乎是一個相當快加載的頁面。

希望這會有所幫助。