Retrieving currency exchange rates online

Question

I am trying to get data in many currencies, and convert all of them to Euro. I found a code on this website, but the code is too advanced for me and is impossible to debug with my knowledge.

I isolated the error, it is when the code reaches xhr.send. Do you have any idea why this would happen?

I do not understand what this part is doing, therefore it is difficult for me to debug it.
The error message that I get is as follow :

Run-time error '-2147012889 (80072ee7)' Automation error

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

EDIT : for any future reader, I Changed my object to msxml2.xmlhttp, now it is working.

Answer 1

It looks OK as I browse it, apart from the object, that I think should use:

CreateObject("MSXML2.ServerXMLHTTP")

You may check out similar code in my project VBA.CurrencyExchange which can retrieve rates from 10 sources. Too much code to post here, but the base function for the ECB is:

' 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

I haven't checked it in Excel, though, only in Access.