VBA 中的 WinHttpRequest 仅在前面有浏览器调用时才有效答案

【问题标题】：WinHttpRequest in VBA only works if preceded by a Browser callVBA 中的 WinHttpRequest 仅在前面有浏览器调用时才有效
【发布时间】：2017-07-30 18:29:37
【问题描述】：

以下网址返回一个带有美元汇率的 XML：

http://www.boi.org.il/currency.xml?curr=01

我需要调用并提取（通过解析结果）从 Excel VBA 返回的速率。

在浏览器中手动调用后在 VBA 中调用时 - 它工作正常。但是，经过一定时间后，它不再从 VBA 中工作，除非先在浏览器中再次手动调用。相反，它会返回此字符串作为结果：

<html><body><script>document.cookie='ddddddd=978a2f9dddddddd_978a2f9d; path=/';window.location.href=window.location.href;</script></body></html>

我用来调用的 VBA 是这样的：

Function GetExchangeRate(ByVal curr As Integer, Optional ByVal exDate As Date = 0) As Single

    Dim strCurrCode As String
    Dim strExDate As String
    Dim strDateParamURL As String
    Dim intStartPos As Integer
    Dim intEndPos As Integer
    Dim sngRate As Single

    sngRate = -1

    On Error GoTo FailedCurr

    strDateParamURL = ""

    strCurrCode = Format(curr, "00")
    If (exDate > 0) Then
        strExDate = Format(exDate, "yyyymmdd")
        strDateParamURL = "&rdate=" & strExDate
    End If


    Dim result As String
    Dim myURL As String
    Dim winHttpReq As Object

    Set winHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")

    myURL = "http://www.boi.org.il/currency.xml"
    myURL = myURL & "?curr=" & strCurrCode & strDateParamURL

    winHttpReq.Open "GET", myURL, False
    winHttpReq.Send

    result = winHttpReq.responseText

    intStartPos = InStr(1, result, "<RATE>") + 6
    intEndPos = InStr(1, result, "</RATE>") - 1

    If (intEndPos > 10) Then
        sngRate = CSng(Mid(result, intStartPos, intEndPos - intStartPos + 1))
    End If
CloseSub:
    GetExchangeRate = sngRate
    Exit Function
FailedCurr:
    GoTo CloseSub
End Function

编辑： 我尝试使用 MSXML2 对象进行此操作 - 完全相同的行为！仅在浏览器激活后有效。这是 XML 代码：

Function GetExchangeRateXML(ByVal curr As Integer, Optional ByVal exDate As Date = 0) As Single

    Dim strDateParamURL As String
    Dim intStartPos As Integer
    Dim intEndPos As Integer
    Dim sngRate As Single
    Dim myURL As String

    sngRate = -1

    ''On Error GoTo FailedCurr

    If (curr = 0) Then
        sngRate = 1
        GoTo CloseSub
    End If

    strDateParamURL = ""

    strCurrCode = Format(curr, "00")
    If (exDate > 0) Then
        strExDate = Format(exDate, "yyyymmdd")
        strDateParamURL = "&rdate=" & strExDate
    End If


    myURL = "http://www.boi.org.il/currency.xml"
    myURL = myURL & "?curr=" & strCurrCode & strDateParamURL

    Dim oXMLFile As Object
    Dim RateNode As Object

    Set oXMLFile = CreateObject("MSXML2.DOMDocument")
    oXMLFile.async = False
    oXMLFile.validateOnParse = False
    oXMLFile.Load (myURL)

    Set RateNode = oXMLFile.SelectNodes("//CURRENCIES/CURRENCY[0]/RATE")


    Debug.Print (RateNode(0).Text)

CloseSub:
    GetExchangeRateXML = CSng(RateNode(0).Text)
    Set RateNode = Nothing
    Set oXMLFile = Nothing

    Exit Function
FailedCurr:
    GoTo CloseSub
End Function

任何想法为什么最初不能从 VBA 函数中工作？

【问题讨论】：

我重新创建了这个错误，它也确实发生在我身上，我打算使用 MSXML2.ServerXMLHTTP60 尝试它，您可以在其中设置请求标头但令人讨厌的是现在我不知道如何恢复到“超时”场景，所以我可以测试它！它通常需要多长时间才能不再起作用？
肯定与他们奇怪的 cookie 有关，在访问该站点时进行网络监视以查看“ddddddd=978a2f9dddddddd_978a2f9d”也许您可以从第一次访问中解析它，然后使用 cookie 设置请求头并重新发送?
可能 - 请参阅我对 MSXML 对象的编辑 - 相同的行为。你能告诉我你所说的带有 cookie 的 setRequestHeader 是什么意思吗？
我将在下面创建一个答案，但我不确定它是否会起作用，这只是我要尝试的第一件事！

标签： excel vba msxml winhttprequest

【解决方案1】：

利用 jamheadart 在初始化调用中捕获 cookie 的方法，我修改了函数以允许在后续 http 请求中通过标头捕获和重新发送 cookie（我在这里最多允许尝试 6 次，但通常两点后结算）。

因此，工作代码是：

Function GetExchangeRate(ByVal curr As Integer, Optional ByVal exDate As Date = 0) As Single
'Finds the exchange rate for a given requested date and requested currency.
'If date is omitted, returns the most recent exchange rate available (web service behavior by design)
'If curr = 0 then return  1 = for New Shekel
'The call to the BOI service first sends a cookie, and only subsequent calls return the XML structure with the result data.
'The cookie has a timeout of several minutes. That's why, we challenge a couple of calls until the cookie string is not returned - then we extract the data from result.

    Dim strCurrCode As String
    Dim strExDate As String
    Dim strDateParamURL As String
    Dim intStartPos As Integer
    Dim intEndPos As Integer
    Dim sngRate As Single

    sngRate = -1

    On Error GoTo FailedCurr

    If (curr = 0) Then
        sngRate = 1
        GoTo CloseSub
    End If

    strDateParamURL = ""

    strCurrCode = Format(curr, "00")
    If (exDate > 0) Then
        strExDate = Format(exDate, "yyyymmdd")
        strDateParamURL = "&rdate=" & strExDate
    End If


    Dim result As String
    Dim myURL As String
    Dim winHttpReq As Object
    Dim i As Integer
    Dim strCookie As String
    Dim intTries As Integer

    Set winHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")

    myURL = "http://www.boi.org.il/currency.xml"
    myURL = myURL & "?curr=" & strCurrCode & strDateParamURL

    With winHttpReq

        .Open "GET", myURL, False
        .Send
        .waitForResponse 4000
        result = .responseText

        'Is cookie received?
        intTries = 1
        Do Until ((InStr(1, result, "cookie") = 0) Or (intTries >= MAX_HTTP_COOKIE_TRIES))

            intStartPos = InStr(1, result, "cookie") + 8
            intEndPos = InStr(1, result, ";") - 1
            strCookie = Mid(result, intStartPos, intEndPos - intStartPos + 1)

            .Open "GET", myURL, False
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .setRequestHeader "Cookie", strCookie
            .Send
            .waitForResponse 4000
            result = .responseText
            intTries = intTries + 1
        Loop

    End With

    'Extract the desired value from result
    intStartPos = InStr(1, result, "<RATE>") + 6
    intEndPos = InStr(1, result, "</RATE>") - 1

    If (intEndPos > 10) Then
        sngRate = CSng(Mid(result, intStartPos, intEndPos - intStartPos + 1))
    End If

CloseSub:
    GetExchangeRate = sngRate
    Set winHttpReq = Nothing
    Exit Function
FailedCurr:
    GoTo CloseSub
End Function

【讨论】：

【解决方案2】：

您可以使用 MSXML2.ServerHttp60 对象而不是 WinHTTP，这样您就可以用它做更多的事情，包括 setTimeOuts 或 setRequestHeader - 对您来说，访问该页面可能值得一试，如果您获得“Cookie”页面，解析cookie，设置“Cookie”请求头，然后使用相同的对象重新发送GET请求。例如。下面是如何设置请求头的代码：

Sub tester()
Dim objCON As MSXML2.ServerXMLHTTP60
Dim URL As String
Dim MYCOOKIE As String

MYCOOKIE = "ddddddd=978a2f9dddddddd_978a2f9d" '(Parsed from first visit)

Set objCON = New MSXML2.ServerXMLHTTP60

    URL = "http://www.boi.org.il/currency.xml?curr=01"

    objCON.Open "GET", URL, False
    objCON.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    objCON.setRequestHeader "Cookie", MYCOOKIE
    objCON.send

    MsgBox (objCON.responseText)

End Sub

【讨论】：

谢谢！您在标头中发回 cookie 的想法成功了！但是，我不能在 Excel VBA 中使用 MSXML2（此外，出于安全原因，它会删除 cookie）。请参阅下面的回复以及工作代码。