如何在 VBA 中重置 XMLHTTP 连接

Question

我正在尝试编写一个 VBA 宏来抓取印度停电的大量数据。该宏应该循环遍历我的 excel 文件中生成的数百个 URL，并为每个 URL 创建一个 XMLHTTP 请求。对于每个 URL，我还会检查当前数据是否可用，并且我会在不可能的情况下获取最新数据。

基本上，只要数据不可用，网站就会给出包含“数据可用于以下日期”的响应以及数据可用的日期。然后，我使用该字符串生成一个指向最新可用数据的新链接。这样一个公式应该变成一个链接，如： https://www.watchyourpower.org/reports.php?location_id=729&from_date=12%2F04%2F2020&to_date=12%2F05%2F2020

变成这样的： https://www.watchyourpower.org/reports.php?location_id=733&from_date=13%2F05%2F2018&to_date=13%2F06%2F2018

一次从一个 URL 中提取数据是可行的，但是当我尝试从如上所述生成的 URL 中提取数据时，我只得到了仍然从第一个请求中缓存的字符串。如何重置 XMLHTTP 请求，以便可以使用替代 URL/循环浏览 Excel 文件中生成的大量 URL？在过去的几个小时里，我一直在搜索论坛，但没有真正找到任何东西。

抱歉，我在这里监督一些事情。我在编码方面不是很有经验，并且从许多不同的论坛帖子中拼接了我的代码，包括 stackoverflow 上的这两个站点： Extract table from webpage using VBA & VBA XMLHTTP clear authentication?

这是我的代码：

Public Sub DataScraper()

Dim sResponse As String, html As HTMLDocument, clipboard, xmlhttp As Object

    Set html = New HTMLDocument
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
    With xmlhttp
        .Open "GET", ThisWorkbook.Sheets("Link Generator").Range("b3").Value, False
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
    End With
    html.body.innerHTML = sResponse


If InStr(html.getElementsByTagName("span")(12).innerText, "Data is available for below date range") > 0 Then
Worksheets("Link Generator").Range("e3") = Right(html.getElementsByTagName("span")(12).innerText, 29)
Worksheets("Link Generator").Calculate


    Set html = New HTMLDocument
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
    With xmlhttp
        .Open "GET", ThisWorkbook.Sheets("Link Generator").Range("g3").Value, False
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
    End With
    html.body.innerHTML = sResponse


End If


    Sheets.Add.Name = Sheets("Link Generator").Range("a3").Value

    With html
        Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        clipboard.SetText .getElementsByTagName("table")(2).outerHTML
        clipboard.PutInClipboard
    End With

    Worksheets(Sheets("Link Generator").Range("a3").Value).Range("b4").PasteSpecial

这总是会导致

对象变量或未设置块变量

行错误：

clipboard.SetText .getElementsByTagName("table")(2).outerHTML

Answer 1

首先，只是一些一般性建议，您可以将创建和发送请求的部分放入其自己的返回 html 的单个函数中，然后您可以在需要时调用它，这样您就不会重复您的代码和您不会冒险使用现有对象 - 例如：

Public Function SendRequest(URL As String) As HTMLDocument
    Dim html As HTMLDocument
    Set html = New HTMLDocument
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
    With xmlhttp
        .Open "GET", URL, False
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
    End With
    html.body.innerHTML = sResponse
    SendRequest = html
End Function

Public Sub DataScraper()

    Dim html As HTMLDocument, clipboard, xmlhttp As Object
    Set html = SendRequest(ThisWorkbook.Sheets("Link Generator").Range("b3").Value)

    If InStr(html.getElementsByTagName("span")(12).innerText, "Data is available for below date range") > 0 Then
        Worksheets("Link Generator").Range("e3") = Right(html.getElementsByTagName("span")(12).innerText, 29)
        Worksheets("Link Generator").Calculate
        Set html = SendRequest(ThisWorkbook.Sheets("Link Generator").Range("g3").Value)
    End If

    Sheets.Add.Name = Sheets("Link Generator").Range("a3").Value

    With html
        Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        clipboard.SetText .getElementsByTagName("table")(2).outerHTML
        clipboard.PutInClipboard
    End With

    Worksheets(Sheets("Link Generator").Range("a3").Value).Range("b4").PasteSpecial
End Sub