CODEWITHSUNDEEP
excelvbamsxmlwinhttprequest
Mor Sagmon
Mor Sagmon

Reputation: 1035

WinHttpRequest in VBA only works if preceded by a Browser call

The following URL returns an XML with USD exchange rate:

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

I need to call and extract (by parsing the result) the returned rate from Excel VBA.

When called in VBA after invoked manually in browser - it works fine. However, after a certain amount of time, it is not working anymore from VBA, unless called manually again in the browser first. Instead, it returns this string as a result: 

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

The VBA I'm using to call is this:

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

EDIT: I tried this using the MSXML2 object - exactly the same behavior! works only after a browser activation. This is the XML code:

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

Any ideas why this is not working initially from the VBA function?

Upvotes: 1

Views: 39380

Answers (2)

Mor Sagmon
Mor Sagmon

Reputation: 1035

leveraging jamheadart's approach to capture the cookie in the initializing call, I modified the function to allow for the cookie to be captured and re-sent via the headers in subsequent http requests (I allow up to 6 tries here, but it usually settles after two).

The working code is therefore:

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

Upvotes: 5

jamheadart
jamheadart

Reputation: 5303

You can use the MSXML2.ServerHttp60 object instead of WinHTTP so you can do more stuff with it, including setTimeOuts or setRequestHeader - for you, it might be worth a shot to visit the page and if you get the "Cookie" page, parse for the cookie, set the "Cookie" request header and then use the same object to resend the GET request. E.g. code below for how to set request headers:

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

Upvotes: 1

Related Questions