VBA对象变量或未设置块变量错误-网页抓取

Question

所以我正在编写一些VBA代码，通过一个网站，我不断得到一个"对象变量或块变量未设置错误"，我通常可以通过代码一步没有错误，这让我相信这是一个时间问题。我用等待语句加载了这段代码，仍然会得到那个错误。任何想法吗?我是不是做了什么疯狂的事?

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

您有一个等待循环来启动站点，但没有等待循环来按下按钮—您只是设置了一个任意的时间—代码在这里抛出错误吗?

我建议使用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差异-这是我可以访问搜索结果的唯一方法)。

一旦搜索被提交，ohttp连接仍然是活动的，你可以使用一个更简单的GET请求(它只依赖于URL -不需要请求的正文字符串)。

GET请求可以导航结果页面(将URL更改为pagerrequested =xyz page，只要您喜欢多次，只需通过简单的循环或其他方式重复两个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引用工作表。

数组中没有7个元素

LArray = Split(LString, vbCrLf)

也许你永远不知道你将拥有多少元素。在这种情况下我会做这个

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

不是

 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)

下面是我的代码，完成了上面所有的修改:

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