VBA 中的 WinHttpRequest 仅在浏览器调用之前有效
WinHttpRequest in VBA only works if preceded by a Browser call
以下URLreturns一个XML美元汇率：
http://www.boi.org.il/currency.xml?curr=01
我需要从 Excel VBA.
中调用并提取（通过解析结果）返回的汇率
在浏览器中手动调用后在 VBA 中调用时 - 它工作正常。但是，在一定时间后，它不再从 VBA 开始工作，除非首先在浏览器中再次手动调用。相反，它 returns 这个字符串作为结果：
<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.ServerHttp60 object 而不是 WinHTTP，这样您就可以用它做更多的事情，包括 setTimeOuts 或 setRequestHeader - 对您来说，它可能值得shot 访问页面，如果你得到 "Cookie" 页面，解析 cookie，设置 "Cookie" 请求 header 然后使用相同的 object 重新发送 GET 请求.例如。下面的代码如何设置请求 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
利用 jamheadart 在初始化调用中捕获 cookie 的方法，我修改了函数以允许捕获 cookie，并在后续 http 请求中通过 headers re-sent（我允许在这里尝试 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
以下URLreturns一个XML美元汇率：
http://www.boi.org.il/currency.xml?curr=01
我需要从 Excel VBA.
中调用并提取（通过解析结果）返回的汇率在浏览器中手动调用后在 VBA 中调用时 - 它工作正常。但是，在一定时间后，它不再从 VBA 开始工作，除非首先在浏览器中再次手动调用。相反，它 returns 这个字符串作为结果：
<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.ServerHttp60 object 而不是 WinHTTP，这样您就可以用它做更多的事情，包括 setTimeOuts 或 setRequestHeader - 对您来说，它可能值得shot 访问页面，如果你得到 "Cookie" 页面，解析 cookie，设置 "Cookie" 请求 header 然后使用相同的 object 重新发送 GET 请求.例如。下面的代码如何设置请求 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
利用 jamheadart 在初始化调用中捕获 cookie 的方法，我修改了函数以允许捕获 cookie，并在后续 http 请求中通过 headers re-sent（我允许在这里尝试 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