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不够，增加更多，但这似乎是一个相当快加载的页面。

希望这会有所帮助。