0

以下 URL 返回带有美元汇率的 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 函数中工作？

4

2 回答 2

4

利用 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
于 2017-07-31T19:39:27.147 回答
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
于 2017-07-30T19:41:31.180 回答