WinHttpRequest在VBA只有工作，如果之前有一个浏览器中调用

问题描述：

以下网址返回与美元汇率的XML：WinHttpRequest在VBA只有工作，如果之前有一个浏览器中调用

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功能？

谢谢！

我重建这个错误，它没有发生在我身上过，我会尝试使用MSXML2.ServerXMLHTTP60在这里你可以设置请求头，但现在烦人我不”不知道如何恢复到“超时”场景，所以我可以测试它！在它不再工作之前，通常需要多长时间？ – jamheadart

肯定有些事情与他们的奇怪的cookie，做一个网络观察，而访问该网站，看到“ddddddd = 978a2f9dddddddd_978a2f9d”也许你可以解析，从第一次访问然后setRequestHeader与cookie并重新发送？ – jamheadart

大概 - 查看我的关于MSXML对象的编辑 - 相同的行为。你可以告诉我你的意思是由cookie的setRequestHeader吗？ –

答

利用jamheadart的方法来捕捉在初始化呼叫饼干，我修改了功能以允许cookie被捕获并在随后的HTTP通过头重新发送请求（我允许在这里尝试多达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

答

您可以使用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

谢谢！你在头部发回cookie的想法的确有窍门！但是，我不能在Excel VBA中使用MSXML2（除此之外，出于安全原因，它会删除Cookie）。请参阅我的回复以及工作代码。 –

很高兴帮助和高兴你得到它的工作:) – jamheadart

WinHttpRequest在VBA只有工作，如果之前有一个浏览器中调用

相关推荐