在线检索货币汇率
Retrieving currency exchange rates online
我正在尝试获取多种货币的数据，并将它们全部转换为欧元。
我在这个网站上找到了一段代码，但是代码对我来说太高级了，以我的知识无法调试。
我找出了错误，是当代码到达xhr.send时。你知道为什么会这样吗？
我不明白这部分是做什么的，所以我很难调试它。
我收到的错误消息如下：
运行-time error '-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
编辑：对于任何未来 reader，我将我的对象更改为 msxml2.xmlhttp，现在它正在工作。
我浏览时看起来不错，除了 object，我认为应该使用：
CreateObject("MSXML2.ServerXMLHTTP")
您可以在我的项目 VBA.CurrencyExchange 中查看类似的代码，它可以从 10 个来源检索汇率。 post 这里的代码太多了，但是 ECB 的基本功能是：
' 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 中检查过。
我正在尝试获取多种货币的数据，并将它们全部转换为欧元。 我在这个网站上找到了一段代码，但是代码对我来说太高级了，以我的知识无法调试。
我找出了错误，是当代码到达xhr.send时。你知道为什么会这样吗？
我不明白这部分是做什么的，所以我很难调试它。
我收到的错误消息如下：
运行-time error '-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
编辑：对于任何未来 reader，我将我的对象更改为 msxml2.xmlhttp，现在它正在工作。
我浏览时看起来不错，除了 object，我认为应该使用：
CreateObject("MSXML2.ServerXMLHTTP")
您可以在我的项目 VBA.CurrencyExchange 中查看类似的代码，它可以从 10 个来源检索汇率。 post 这里的代码太多了，但是 ECB 的基本功能是：
' 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 中检查过。