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

謝謝！

來源

2017-07-30 Mor Sagmon

我重建這個錯誤，它沒有發生在我身上過，我會嘗試使用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

來源

2017-07-31 19:39:27

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

來源

2017-07-30 19:41:31 jamheadart

謝謝！你在頭部發回cookie的想法的確有竅門！但是，我不能在Excel VBA中使用MSXML2（除此之外，出於安全原因，它會刪除Cookie）。請參閱我的回覆以及工作代碼。 –

很高興幫助和高興你得到它的工作:) – jamheadart

WinHttpRequest在VBA只有工作，如果之前有一個瀏覽器中調用

回答

相關問題