VBA 中的 WinHttpRequest 仅在浏览器调用之前有效
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/45403259/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
WinHttpRequest in VBA only works if preceded by a Browser call
提问by Mor Sagmon
The following URL returns an XML with USD exchange rate:
以下 URL 返回带有美元汇率的 XML：
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.
我需要从 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:
在浏览器中手动调用后在 VBA 中调用时 - 它工作正常。但是，一段时间后，它不再从 VBA 工作，除非先在浏览器中再次手动调用。相反，它返回此字符串作为结果：
<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:
我用来调用的 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
EDIT:I tried this using the MSXML2 object - exactly the same behavior! works only after a browser activation. This is the XML code:
编辑：我尝试使用 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
Any ideas why this is not working initially from the VBA function?
任何想法为什么这在 VBA 函数中最初不起作用？
回答by Mor Sagmon
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).
利用 jamheadart 在初始化调用中捕获 cookie 的方法，我修改了该函数以允许捕获 cookie 并通过后续 http 请求中的标头重新发送（我在这里最多允许 6 次尝试，但通常在两个）。
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
回答by jamheadart
You can use the MSXML2.ServerHttp60 object instead of WinHTTP so you can do more stuff with it, including setTimeOutsor 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:
您可以使用 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
