如何在 VBA 中重置 XMLHTTP 連接

Question

我正在嘗試編寫一個 VBA 宏來抓取印度停電的一堆數據。 該宏應該循環遍歷在我的 excel 文件中生成的數百個 URL，並為每個 URL 創建一個 XMLHTTP 請求。 對於每個 URL，我還在檢查當前數據是否可用，並且我正在獲取不可能的最新數據。

基本上，每當數據不可用時，網站都會給出包含“數據可用於以下日期”的響應以及數據可用的日期。 然后，我使用該字符串生成一個指向最新可用數據的新鏈接。 這樣一個公式應該會變成這樣的鏈接： https://www.watchyourpower.org/reports.php?location_id=729&from_date=12%2F04%2F2020&20200002%2F05

變成類似： 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 上的這兩個站點： 使用 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

這總是導致

Object 變量或未設置塊變量

在線錯誤：

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

Answer 1

對於開始，只是一些一般性建議，您可以將創建和發送請求的位置放入它自己的單個 function 中，該 function 返回 html，然后您可以在需要時調用它，這樣您就不會重復您的代碼t 冒險使用現有的 object - 類似於：

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