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?
Answer
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