Question

以下网址返回带有美元汇率的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功能？

谢谢！

Answer 1

你可以使用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

Answer 2

利用jamheadart的方法在初始化调用中捕获cookie，我修改了函数以允许cookie被捕获并通过后续http请求中的头重新发送（我允许最多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

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

2 个答案: