在線檢索貨幣匯率

Question

我正在嘗試以多種貨幣獲取數據，並將它們全部轉換為歐元。 我在這個網站上找到了一段代碼，但是代碼對我來說太高級了，無法以我的知識進行調試。

我隔離了錯誤，它是在代碼到達xhr.send 時。 你知道為什么會發生這種情況嗎？

我不明白這部分在做什么，因此我很難調試它。
我得到的錯誤信息如下：

運行時錯誤 '-2147012889 (80072ee7)' 自動化錯誤

Sub test()

Dim test1 As Variant

test1 = ConvCurrency(1, "USD", "GBP")
MsgBox (test1)

End Sub

''
' UDF to convert a currency using the daily updated rates fron the European Central Bank  '
'  =ConvCurrency(1, "USD", "GBP")                                                         '
''


 Public Function ConvCurrency(Value, fromSymbol As String, toSymbol As String)
  Static rates As Collection, expiration As Date  ' cached / keeps the value between calls '

  If DateTime.Now > expiration Then
    Dim xhr As Object, node As Object
    expiration = DateTime.Now + DateTime.TimeSerial(1, 0, 0) ' + 1 hour '

    Set rates = New Collection
    rates.Add 1#, "EUR"

    Set xhr = CreateObject("Msxml2.ServerXMLHTTP.6.0")
    xhr.Open "GET", "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml", False
    xhr.Send

    For Each node In xhr.responseXML.SelectNodes("//*[@rate]")
      rates.Add Conversion.Val(node.GetAttribute("rate")), node.GetAttribute("currency")
    Next
  End If

  ConvCurrency = (Value / rates(fromSymbol)) * rates(toSymbol)
End Function

編輯：對於任何未來的讀者，我將我的對象更改為msxml2.xmlhttp ，現在它正在工作。

Answer 1

除了我認為應該使用的object之外，我瀏覽它時看起來還可以：

CreateObject("MSXML2.ServerXMLHTTP")

您可以查看我的項目VBA.CurrencyExchange 中的類似代碼，它可以從 10 個來源檢索匯率。 在這里發布太多代碼，但歐洲央行的基本功能是：

' Retrieve the current exchange rates from the European Central Bank, ECB,
' for Euro having each of the listed currencies as the base currency.
' The rates are returned as an array and cached until the next update.
' The rates are updated once a day at about UTC 15:00.
'
' Source:
'   http://www.ecb.europa.eu/stats/policy_and_exchange_rates/euro_reference_exchange_rates/html/index.en.html
'
' Note:
'   The exchange rates on the European Central Bank's website are indicative rates
'   that are not intended to be used in any market transaction.
'   The rates are intended for information purposes only.
'
' Example:
'   Dim Rates As Variant
'   Rates = ExchangeRatesEcb()
'   Rates(7, 0) -> 2018-05-30       ' Publishing date.
'   Rates(7, 1) -> "PLN"            ' Currency code.
'   Rates(7, 2) -> 4.3135           ' Exchange rate.
'
' 2018-06-07. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function ExchangeRatesEcb() As Variant

    ' Operational constants.
    '
    ' Base URL for European Central Bank exchange rates.
    Const ServiceUrl    As String = "http://www.ecb.europa.eu/stats/eurofxref/"
    ' File to look up.
    Const Filename      As String = "eurofxref-daily.xml"
    ' Update hour (UTC).
    Const UpdateHour    As Date = #3:00:00 PM#
    ' Update interval: 24 hours.
    Const UpdatePause   As Integer = 24
    
    ' Function constants.
    '
    ' Async setting.
    Const Async         As Variant = False
    ' XML node and attribute names.
    Const RootNodeName  As String = "gesmes:Envelope"
    Const CubeNodeName  As String = "Cube"
    Const TimeNodeName  As String = "Cube"
    Const TimeItemName  As String = "time"
    Const CodeItemName  As String = "currency"
    Const RateItemName  As String = "rate"
  
#If EarlyBinding Then
    ' Microsoft XML, v6.0.
    Dim Document        As MSXML2.DOMDocument60
    Dim XmlHttp         As MSXML2.ServerXMLHTTP60
    Dim RootNodeList    As MSXML2.IXMLDOMNodeList
    Dim CubeNodeList    As MSXML2.IXMLDOMNodeList
    Dim RateNodeList    As MSXML2.IXMLDOMNodeList
    Dim RootNode        As MSXML2.IXMLDOMNode
    Dim CubeNode        As MSXML2.IXMLDOMNode
    Dim TimeNode        As MSXML2.IXMLDOMNode
    Dim RateNode        As MSXML2.IXMLDOMNode
    Dim RateAttribute   As MSXML2.IXMLDOMAttribute

    Set Document = New MSXML2.DOMDocument60
    Set XmlHttp = New MSXML2.ServerXMLHTTP60
#Else
    Dim Document        As Object
    Dim XmlHttp         As Object
    Dim RootNodeList    As Object
    Dim CubeNodeList    As Object
    Dim RateNodeList    As Object
    Dim RootNode        As Object
    Dim CubeNode        As Object
    Dim TimeNode        As Object
    Dim RateNode        As Object
    Dim RateAttribute   As Object

    Set Document = CreateObject("MSXML2.DOMDocument")
    Set XmlHttp = CreateObject("MSXML2.ServerXMLHTTP")
#End If

    Static Rates()      As Variant
    Static LastCall     As Date
    
    Dim Url             As String
    Dim CurrencyCode    As String
    Dim Rate            As String
    Dim ValueDate       As Date
    Dim ThisCall        As Date
    Dim Item            As Integer
    
    
    If DateDiff("h", LastCall, UtcNow) < UpdatePause Then
        ' Return cached rates.
    Else
        ' Retrieve updated rates.
    
        ' Define default result array.
        ' Redim for three dimensions: date, code, rate.
        ReDim Rates(0, 0 To 2)
        Rates(0, RateDetail.Date) = NoValueDate
        Rates(0, RateDetail.Code) = NeutralCode
        Rates(0, RateDetail.Rate) = NeutralRate
        
        Url = ServiceUrl & Filename
        
        ' Retrieve data.
        XmlHttp.Open "GET", Url, Async
        XmlHttp.Send
        
        If XmlHttp.Status = HttpStatus.OK Then
            ' File retrieved successfully.
            Document.loadXML XmlHttp.ResponseText
        
            Set RootNodeList = Document.getElementsByTagName(RootNodeName)
            ' Find root node.
            For Each RootNode In RootNodeList
                If RootNode.nodeName = RootNodeName Then
                    Exit For
                Else
                    Set RootNode = Nothing
                End If
            Next
            
            If Not RootNode Is Nothing Then
                If RootNode.hasChildNodes Then
                    ' Find first level Cube node.
                    Set CubeNodeList = RootNode.childNodes
                    For Each CubeNode In CubeNodeList
                        If CubeNode.nodeName = CubeNodeName Then
                            Exit For
                        Else
                            Set CubeNode = Nothing
                        End If
                    Next
                End If
            End If
            If Not CubeNode Is Nothing Then
                If CubeNode.hasChildNodes Then
                    ' Find second level Cube node.
                    Set CubeNodeList = CubeNode.childNodes
                    For Each TimeNode In CubeNodeList
                        If TimeNode.nodeName = TimeNodeName Then
                            Exit For
                        Else
                            Set TimeNode = Nothing
                        End If
                    Next
                End If
            End If
            
            If Not TimeNode Is Nothing Then
                If TimeNode.hasChildNodes Then
                    ' Find value date.
                    ValueDate = CDate(TimeNode.Attributes.getNamedItem(TimeItemName).nodeValue)
                    
                    ' Find the exchange rates.
                    Set RateNodeList = TimeNode.childNodes
                    ' Redim for three dimensions: date, code, rate.
                    ReDim Rates(RateNodeList.Length - 1, 0 To 2)
                    For Each RateNode In RateNodeList
                        Rates(Item, RateDetail.Date) = ValueDate
                        If RateNode.Attributes.Length > 0 Then
                            ' Get the ISO currency code.
                            Set RateAttribute = RateNode.Attributes.getNamedItem(CodeItemName)
                            If Not RateAttribute Is Nothing Then
                                CurrencyCode = RateAttribute.nodeValue
                            End If
                            ' Get the exchange rate for this currency code.
                            Set RateAttribute = RateNode.Attributes.getNamedItem(RateItemName)
                            If Not RateAttribute Is Nothing Then
                                Rate = RateAttribute.nodeValue
                            End If
                            Rates(Item, RateDetail.Code) = CurrencyCode
                            Rates(Item, RateDetail.Rate) = CDbl(Val(Rate))
                        End If
                        Item = Item + 1
                    Next RateNode
                End If
            End If
            
            ThisCall = ValueDate + UpdateHour
            ' Record requested language and publishing time of retrieved rates.
            LastCall = ThisCall
            
        End If
    End If
    
    ExchangeRatesEcb = Rates

End Function

不過，我還沒有在 Excel 中檢查過它，只在 Access 中檢查過。