本文介绍了如何在VBA中从多种来源获取汇率，包括免费和付费服务，如欧洲中央银行、丹麦国家银行等。服务提供XML、JSON和HTML格式的数据，通过API或网页抓取。代码模块支持早期和晚期绑定，适用于32位和64位系统。文章还提供了转换货币的函数，以及如何存储和使用汇率的示例。
vba 时间换算
服务及其功能 (Services and their features)
Exchange rates can be obtained from many sources, some free, some paid.
汇率可以从许多来源获得，有的是免费的，有的是付费的。
Hardly two of these serve the same purpose or are targeted the same users. This means, that some research typically is necessary to pick the service that will fit a given scenario and demand. Several factors come into play:
其中几乎没有两个服务于相同的目的或针对相同的用户。 这意味着，通常需要进行一些研究才能选择适合给定场景和需求的服务。 有几个因素起作用：
- authority - rates provided by national banks have high trust 授权-国家银行提供的利率具有高度信任
- interface - what code is needed to retrieve the data 界面-检索数据需要什么代码
- range of currencies - from and to which currencies is the demand for 货币的范围- 从和向哪个货币为所述需求
- update frequency - once a day or more often 更新频率-每天一次或更频繁
- costs - can a fee be accepted, or must the service be free to use 费用-可以接受费用，还是必须免费使用服务
Only one factor - code examples for the interfaces - we take care of here; the rest is up to you, and you will have to visit the various websites to obtain the current details and further info before making a decision.
只有一个因素-接口的代码示例-我们在这里处理； 其余的一切取决于您，您将需要访问各个网站以获取当前的详细信息和更多信息，然后再做出决定。
提供的服务 (Services offered)
The services, that this project addresses, are:
该项目要解决的服务是：
1. The European Central Bank
1.欧洲中央银行
2. The Danish National Bank
2.丹麦国家银行
3. The Central Bank of the Russian Federation
3.俄罗斯联邦中央银行
4. Currency Converter API
4.货币转换器API
5. Currencylayer API
5. Currencylayer API
6. ExchangeRate API
6. ExchangeRate API
7. Fixer
7.固定器
8. Open Exchange Rates
8.开放汇率
9. php.mk - National Bank of the Republic of North Macedonia
9. php.mk-北马其顿共和国国家银行
10. XE
10. XE
All services support the currencies commonly used in international trade; for more exotic currencies, you may be limited in the choice of service.
所有服务都支持国际贸易中常用的货币； 对于更多外来货币，您可能无法选择服务。
For free, a few services provide exchange rates from any base currency, some provide exchange rates based on one currency only, some only one or a few currencies based on any currency, and one provides exchange rates to one currency only (Euro, The European Central Bank). One service, XE, offers no free plan or subscription at all, only a seven-day trial.
免费提供一些服务，可以提供任何基础货币的汇率，一些服务仅提供基于一种货币的汇率，一些服务仅提供一种或几种基于任何货币的汇率，而一种服务仅提供对一种货币的汇率（欧元，欧洲中央银行）。 XE一项服务根本不提供免费计划或订阅，仅提供7天的试用期。
The exchange rates published by the services are what is called mid-market rates. This means, that they cannot be used for real transactions; for such, you must refer to the actual buying and selling rates of your bank or broker.
这些服务发布的汇率称为中端市场汇率 。 这意味着它们不能用于真实交易； 为此，您必须参考银行或经纪人的实际买卖价格。
功能 (Functions)
Like the services differ in offerings, so do the various APIs or download options, though only three basic techniques are used:
就像服务在提供的产品中有所不同一样，各种API或下载选项也是如此，尽管仅使用了三种基本技术：
- addressing an API, delivering data as Json 解决API，以Json的形式传递数据
- reading an XML document 读取XML文档
- parsing an HTML document (web scraping, data extracting) 解析HTML文档（网络抓取，数据提取）
However, no two services - even using the same basic technique - offer the same data format; thus a custom function is required for each service.
但是，即使使用相同的基本技术，也没有两个服务提供相同的数据格式。 因此，每个服务都需要自定义功能。
The main functions offered are named:
提供的主要功能为：
ExchangeRatesXyz
ExchangeRatesXyz
where Xyz is a three-letter abbreviation of the service name.
Xyz是服务名称的三个字母的缩写。
Each of these functions returns an array with the rates, and also attempts to cache the download for two reasons:
这些函数中的每一个都会返回一个包含费率的数组，并出于两个原因而尝试缓存下载：
- to speed up reading the rates multiple times 加快多次读取汇率
- to save the usage of and the load on the service 以节省服务的使用和负载
The returned array is simple - with three or four dimensions of various data types:
返回的数组很简单-具有三个或四个维度的各种数据类型：
- Publishing date (Date) 出版日期（日期）
- ISO currency code (Three-letter string) ISO货币代码（三字母字符串）
- Exchange rate (Double) 汇率（双倍）
- (Optional) Currency name (string) （可选）货币名称（字符串）
Thus, a typical call will be:
因此，典型的调用将是：
Dim ArrayOfExhangeRates As Variant
ArrayOfExhangeRates = ExchangeRatesXyz()
The functions are supplemented with a set of matching functions for converting an amount from one currency to another. These are named in a similar way:
这些功能补充有一组匹配功能，用于将金额从一种货币转换为另一种货币。 这些以类似的方式命名：
CurrencyConvertXyz
CurrencyConvertXyz
These functions each utilise the output from the corresponding ExchangeRatesXyz function. Further, they cache the conversion factor for a set of currencies to speed up the calculation of many amounts between the same two currencies.
这些函数各自利用相应的ExchangeRatesXyz函数的输出。 此外，它们缓存一组货币的转换因子，以加快相同两种货币之间许多金额的计算。
The returned value is the conversion factor between the two passed currency codes, for example:
返回值是两个传递的货币代码之间的转换因子 ，例如：
Dim ConversionFactor As Double
ConversionFactor = CurrencyConvertXyz("BBB", AAA")
All functions support the neutral currency code XXX for an exchange rate of 1.
所有功能均支持1汇率的中性货币代码 XXX 。
(
)
早期或晚期绑定（32位或64位） (Early or late binding, 32- or 64-bit)
Where relevant, all functions support both early and late binding. Code has been tested with both 32-bit and 64-bit Microsoft Access 2016 and Access 365.
在相关情况下，所有功能均支持早期和晚期绑定。 代码已通过32位和64位Microsoft Access 2016和Access 365进行了测试 。
The Json modules from the project VBA.CVRAPI are required for those functions that retrieve data as Json.
那些将数据作为Json检索的功能需要项目VBA.CVRAPI中的Json模块。
服务内容 (The services)
1.欧洲中央银行 (1. The European Central Bank)
2.丹麦国家银行 (2. The Danish National Bank)
The ECB and The Danish National Bank offer a daily list of exchange rates for selected currencies, indeed all the European other than Euro. These can be downloaded as an XML file, but our functions read them directly and transform them to an array in a few steps.
欧洲央行和丹麦国家银行提供特定货币的每日汇率清单，实际上是除欧元以外的所有欧洲货币。 这些可以作为XML文件下载，但是我们的函数可以直接读取它们，并通过几个步骤将它们转换为数组。
Note the use of static variables to prevent unnecessary repeated calls to the site. Effectively, the data will only be retrieved once per day. After the first call, the static array Rates, holding the exchange rates of the day, will be returned directly for all subsequent calls, speeding these up vastly.
请注意使用静态变量，以防止不必要的重复调用该站点。 实际上，每天仅检索一次数据。 第一次通话后，将为以后的所有通话直接返回保存当天汇率的静态数组Rates，从而大大加快了通话速度。
The in-line comments explain each step, for example for the 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
The corresponding conversion functions are also similar. They look up the exchange rates for the two currencies from the retrieved array, and then calculate the relation between these, for example:
相应的转换函数也相似。 他们从检索到的数组中查找两种货币的汇率，然后计算它们之间的关系，例如：
' Returns the current conversion factor from Danish Krone to another currency
' based on the official exchange rates published by the Danish National Bank.
'
' Optionally, the conversion factor can be calculated from any other of the
' published exchange rates. Exchange rates for other base currencies are
' calculated from DKK by triangular calculation.
'
' Source:
' http://www.nationalbanken.dk/en/statistics/exchange_rates/Pages/default.aspx
'
' If an invalid or unpublished currency code is passed, a conversion factor
' of zero is returned.
'
' Examples, typical:
' CurrencyConvertDkk("EUR") -> 0.134062634062634
' CurrencyConvertDkk("EUR", "DKK") -> 0.134062634062634
' CurrencyConvertDkk("AUD") -> 0.21661901048436
' CurrencyConvertDkk("AUD", "DKK") -> 0.21661901048436
' CurrencyConvertDkk("DKK", "AUD") -> 4.6164
' CurrencyConvertDkk("DKK", "EUR") -> 7.4592
' CurrencyConvertDkk("AUD", "EUR") -> 1.61580452300494
' CurrencyConvertDkk("", "EUR") -> 7.4592
' CurrencyConvertDkk("DKK") -> 1
' Examples, neutral code.
' CurrencyConvertDkk("AUD", "XXX") -> 1
' CurrencyConvertDkk("XXX", "AUD") -> 1
' CurrencyConvertDkk("XXX") -> 1
' Examples, invalid code.
' CurrencyConvertDkk("XYZ") -> 0
' CurrencyConvertDkk("EUR", "XYZ") -> 0
'
' 2018-09-24. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function CurrencyConvertDkk( _
ByVal IsoTo As String, _
Optional ByVal IsoFrom As String = DanishKroneCode) _
As Double
Dim Rates() As Variant
Dim RateTo As Double
Dim RateFrom As Double
Dim Factor As Double
Dim Index As Integer
If IsoFrom = "" Then
IsoFrom = DanishKroneCode
End If
If IsoTo = "" Then
IsoTo = DanishKroneCode
End If
If IsoTo = NeutralCode Or IsoFrom = NeutralCode Then
Factor = NeutralRate
ElseIf IsoTo = IsoFrom Then
Factor = NeutralRate
Else
Rates() = ExchangeRatesDkk
If IsoTo = DanishKroneCode Then
RateTo = NeutralRate
Else
For Index = LBound(Rates) To UBound(Rates)
If Rates(Index, RateDetail.Code) = IsoTo Then
RateTo = Rates(Index, RateDetail.Rate)
Exit For
End If
Next
End If
If RateTo > NoRate Then
If IsoFrom = DanishKroneCode Then
RateFrom = NeutralRate
Else
For Index = LBound(Rates) To UBound(Rates)
If Rates(Index, RateDetail.Code) = IsoFrom Then
RateFrom = Rates(Index, RateDetail.Rate)
Exit For
End If
Next
End If
Factor = RateFrom / RateTo
End If
End If
CurrencyConvertDkk = Factor
End Function
Note, that repeated calls will be very fast, as the exchange rates will be retrieved from the cached data in function ExchangeRatesXyz.
请注意，重复调用将非常快，因为将从功能ExchangeRatesXyz中的缓存数据中检索汇率。
3.俄罗斯联邦中央银行 (3. The Central Bank of the Russian Federation)
Exchange rates from this site are available as part of a page - a html table holding the rates. This calls for a different technique than above (for XML data) as the full page has to be retrieved and then parsed to locate the table. If success, the table is then read and converted to our array.
来自该网站的汇率可以作为页面的一部分使用-包含汇率的html表 。 由于需要检索整页然后进行解析以查找表，因此这需要一种不同于上述（用于XML数据）的技术。 如果成功，则读取表并将其转换为我们的数组。
Locating the publishing date takes an additional step.
确定发布日期还需要执行其他步骤。
On top of this, the data must be read as a stream to be able to apply the correct character set, or the Russian names for the currencies would be garbled. ADO is used for this.
最重要的是，必须将数据读取为流，以便能够应用正确的字符集，否则，货币的俄语名称会出现乱码。 ADO用于此目的。
"Scraping data" as this is, is a very slow method - and risky too, as you have no guarantee that the page won't change causing the function to fail. However, currently it works well, and - as these data also will be cached - for repeated calls, it will be as fast as the other methods (XML or Json data).
这样的“抓取数据”是一种非常慢的方法-也是有风险的，因为您不能保证页面不会更改而导致功能失败。 但是，当前它运行良好，并且-由于也会缓存这些数据-对于重复调用，它将与其他方法（XML或Json数据）一样快。
Again, study the in-line comments to follow the steps taken:
再次，研究在线注释以遵循以下步骤：
' Retrieve the current exchange rates from the Central Bank of the Russian
' Federation having RUB 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 13:00.
'
' Source:
' https://cbr.ru/eng/currency_base/daily/
'
' Note:
' The Central Bank of the Russian Federation has set the exchange rates of
' foreign currencies against the ruble without assuming any liability to
' buy or sell foreign currency at the rates.
'
' Example:
' Dim Rates As Variant
' Rates = ExchangeRatesCbr()
' Rates(9, 0) -> 2018-10-06 ' Publishing date.
' Rates(9, 1) -> "DKK" ' Currency code.
' Rates(9, 2) -> 10.2697 ' Exchange rate.
' Rates(9, 3) -> "Danish Krone" ' Currency name in English.
'
' 2018-10-07. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function ExchangeRatesCbr( _
Optional ByVal LanguageCode As String) _
As Variant
' Operational constants.
'
' API endpoints.
Const RuServiceUrl As String = "https://cbr.ru/currency_base/daily/"
Const EnServiceUrl As String = "https://cbr.ru/eng/currency_base/daily/"
' Functional constants.
'
' Page encoding.
Const Characterset As String = "UTF-8"
' Async setting.
Const Async As Variant = False
' Class name of data table.
Const DataClassName As String = "data"
' Field items of html table.
Const CodeField As Integer = 1
Const NameField As Integer = 3
Const UnitField As Integer = 2
Const RateField As Integer = 4
' Locater/header for publishing date: "DT":".
Const DateHeader As String = """DT"":"""
' Length of formatted date: 2000-01-01.
Const DateLength As Integer = 10
' Update hour (UTC).
Const UpdateHour As Date = #1:00:00 PM#
' Update interval: 24 hours.
Const UpdatePause As Integer = 24
' English language code.
Const EnglishCode As String = "en"
' Russion language code.
Const RussianCode As String = "ru"
#If EarlyBinding Then
' Microsoft XML, v6.0.
Dim XmlHttp As MSXML2.ServerXMLHTTP60
' Microsoft ActiveX Data Objects 6.1 Library.
Dim Stream As ADODB.Stream
' Microsoft HTML Object Library.
Dim Document As MSHTML.HTMLDocument
Dim Scripts As MSHTML.IHTMLElementCollection
Dim Script As MSHTML.HTMLHtmlElement
Dim Tables As MSHTML.IHTMLElementCollection
Dim Table As MSHTML.HTMLHtmlElement
Dim Rows As MSHTML.IHTMLElementCollection
Dim Row As MSHTML.HTMLHtmlElement
Dim Fields As MSHTML.IHTMLElementCollection
Set XmlHttp = New MSXML2.ServerXMLHTTP60
Set Stream = New ADODB.Stream
Set Document = New MSHTML.HTMLDocument
#Else
Dim XmlHttp As Object
Dim Stream As Object
Dim Document As Object
Dim Scripts As Object
Dim Script As Object
Dim Tables As Object
Dim Table As Object
Dim Rows As Object
Dim Row As Object
Dim Fields As Object
Set XmlHttp = CreateObject("MSXML2.ServerXMLHTTP")
Set Stream = CreateObject("ADODB.Stream")
Set Document = CreateObject("htmlfile")
#End If
Static Rates() As Variant
Static LastCall As Date
Static LastCode As String
Dim ServiceUrl As String
Dim RateCount As Integer
Dim Published As String
Dim ValueDate As Date
Dim ThisCall As Date
Dim Text As String
Dim Index As Integer
Dim Unit As Double
Dim ScaledRate As Double
Dim TrueRate As Double
If StrComp(LanguageCode, RussianCode, vbTextCompare) = 0 Then
LanguageCode = RussianCode
ServiceUrl = RuServiceUrl
Else
LanguageCode = EnglishCode
ServiceUrl = EnServiceUrl
End If
If LastCode = LanguageCode And DateDiff("h", LastCall, UtcNow) < UpdatePause Then
' Return cached rates.
Else
' Retrieve updated rates.
' Define default result array.
' Redim for four dimensions: date, code, rate, name.
ReDim Rates(0, 0 To 3)
Rates(0, RateDetail.Date) = NoValueDate
Rates(0, RateDetail.Code) = NeutralCode
Rates(0, RateDetail.Rate) = NeutralRate
Rates(0, RateDetail.Name) = NeutralName
' Retrieve data.
XmlHttp.Open "GET", ServiceUrl, Async
XmlHttp.Send
If XmlHttp.Status = HttpStatus.OK Then
' Retrieve and convert the page.
' The default character set cannot be used. See:
' https://stackoverflow.com/a/23812869/3527297
' Write the raw bytes to the stream.
Stream.Open
Stream.Type = adTypeBinary
Stream.Write XmlHttp.responseBody
' Read text characters from the stream applying the character set.
Stream.Position = 0
Stream.Type = adTypeText
Stream.Charset = Characterset
' Copy the page to the document object.
Document.body.innerHTML = Stream.ReadText
' Search the scripts to locate the publishing date.
Set Scripts = Document.getElementsByTagName("script")
ValueDate = Date
For Each Script In Scripts
Text = Script.innerHTML
If InStr(Text, "uniDbQuery_Data =") > 0 Then
Published = Left(Split(Text, DateHeader)(1), DateLength)
If IsDate(Published) Then
ValueDate = CDate(Published)
End If
Exit For
End If
Next
' Search the tables to locate the data table.
' Doesn't work with late binding.
' Set Tables = Document.getElementsByClassName("data")
Set Tables = Document.getElementsByTagName("table")
For Each Table In Tables
If Table.className = DataClassName Then
Exit For
End If
Next
If Not Table Is Nothing Then
' The table was found.
Set Rows = Table.getElementsByTagName("tr")
' Reduce the count by one to skip the header row.
RateCount = Rows.Length - 1
' Redim for four dimensions: date, code, rate, name.
ReDim Rates(0 To RateCount - 1, 0 To 3)
' Fill the array of rates.
For Index = LBound(Rates, 1) To UBound(Rates, 1)
' Offset Index by one to skip the header row.
Set Row = Rows.Item(Index + 1)
' Get the fields of this rate.
Set Fields = Row.getElementsByTagName("td")
' The returned rates are scaled to hold four decimals only.
' Calculate the true (non-scaled) rate.
ScaledRate = Val(Replace(Fields.Item(RateField).innerText, ",", "."))
Unit = Val(Fields.Item(UnitField).innerText)
TrueRate = ScaledRate / Unit
Rates(Index, RateDetail.Date) = ValueDate
Rates(Index, RateDetail.Code) = Fields.Item(CodeField).innerText
Rates(Index, RateDetail.Rate) = TrueRate
Rates(Index, RateDetail.Name) = Fields.Item(NameField).innerHTML
Next
End If
ThisCall = ValueDate + UpdateHour
' Record requested language and publishing time of retrieved rates.
LastCode = LanguageCode
LastCall = ThisCall
End If
End If
ExchangeRatesCbr = Rates
End Function
The associated CurrencyConvertCbr function is nearly identical to the one already listed, so I won't list it here.
相关的CurrencyConvertCbr函数与已经列出的函数几乎相同，因此在此不再列出。
4.货币转换器API (4. Currency Converter API)
Contrary to the other services, this on supplies only one or a few specified exchange rates. For this reason - and, again, to avoid repeated calls for the same information - the retrieved exchange rates are collected in a collection. Further, for simplicity, our code will only retrieve one exchange rate per call.
与其他服务相反，此服务仅提供一个或几个指定汇率。 因此，并且为了避免重复调用相同的信息，将取回的汇率收集在collection中 。 此外，为简单起见，我们的代码每次调用将仅检索一种汇率。
This means that if you, for example, wish to have the exchange rates for USD, RUB, and DKK against EUR, you will make three calls and, for each call, add the retrieved exchange rate information to the collection, thus "building up" the array of exchange rates returned.
这意味着，例如，如果您希望拥有USD，RUB和DKK对EUR的汇率，您将进行三个调用，并针对每个调用将检索到的汇率信息添加到集合中，从而“建立返回的汇率数组。
Each step is carefully commented in-line to make it easy to follow the flow. Note please, that the Json data is retrieved and decoded by the functions RetrieveDataResponse and CollectJson from my project VBA.CVRAPI (link above):
每个步骤都经过仔细的在线注释，以使其易于遵循流程。 请注意，Json数据是通过RetrieveDataResponse和CollectJson函数从我的项目VBA.CVRAPI中检索和解码的（上面的链接）：
' Retrieve the current exchange rate from "Currency Converter API" for one base currency.
' The requested rate is returned as an array and cached until the next update.
' All retrieved rates are cached in a collection until the next update.
' The rates are updated from once per hour down to once per minute.
'
' Default base currency is EUR.
' Default rate is for USD.
'
' Source:
' https://currencyconverterapi.com/
' https://currencyconverterapi.com/docs
'
' Note:
' The services are provided as is and without warranty.
'
' Example:
' Dim Rates As Variant
' Rates = ExchangeRatesCca()
' Rates(0, 0) -> 2018-09-24 07:56:50 ' Publishing date.
' Rates(0, 1) -> "USD" ' Currency code.
' Rates(0, 2) -> 1.17395 ' Exchange rate.
'
' 2018-09-24. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function ExchangeRatesCca( _
Optional ByVal IsoBase As String = EuroCode, _
Optional ByVal IsoTo As String = USDollarCode) _
As Variant
' Operational constants.
'
' API endpoint.
Const FreeSubdomain As String = "free"
Const PaidSubdomain As String = "api"
Const TempSubdomain As String = "xxx"
' API version must be 3 or higher.
Const ApiVersion As String = "6"
Const ServiceUrl As String = "https://" & TempSubdomain & ".currencyconverterapi.com/api/v" & ApiVersion & "/convert"
' Data styles. For reference only; must be "ultra".
Const CompactStyle As String = "ultra"
Const ExtendedStyle As String = ""
' Update interval: 60, 15, or 1 minutes.
Const UpdatePause As Integer = 60
' Function constants.
'
' Default currency code. Can be any valid currency codes.
Const DefaultBase As String = EuroCode
Const DefaultTo As String = USDollarCode
' Node names in retrieved collection.
Const RootNodeName As String = "root"
' ResponseText when invalid currency code is passed.
Const EmptyResponse As String = "{}"
Static CodePairs As Collection
Static Rates() As Variant
Static LastCodePair As String
Static LastCall As Date
Dim DataCollection As Collection
Dim Parameter() As String
Dim Parameters() As String
Dim UrlParts(1) As String
Dim Subdomain As String
Dim CodePair As String
Dim RateItem As Variant
Dim Index As Integer
Dim Url As String
Dim ResponseText As String
Dim ValueDate As Date
Dim ThisCall As Date
Dim IsCurrent As Boolean
' Assemple code pair.
If IsoBase = "" Then
IsoBase = DefaultBase
End If
If IsoTo = "" Then
IsoTo = DefaultTo
End If
CodePair = Trim(Left(UCase(IsoBase), 3)) & "_" & Trim(Left(UCase(IsoTo), 3))
' Is the current collection of rates up-to-date?
IsCurrent = DateDiff("n", LastCall, Now) < UpdatePause
If IsCurrent And LastCodePair = CodePair Then
' Return cached rate.
ElseIf IsCurrent And IsCollectionItem(CodePairs, CodePair) Then
' Return stored rate from collection.
Rates = CodePairs(CodePair)
LastCodePair = CodePair
Else
' Retrieve the code pair and add it to the collection of code pairs.
If IsCurrent Then
' Keep the stored code pairs.
Else
' Clear all stored code pairs.
Set CodePairs = New Collection
End If
' Set subdomain to call.
If CcaApiId = "" Then
' Free plan is used.
Subdomain = FreeSubdomain
Else
' Paid plan is used.
Subdomain = PaidSubdomain
End If
' Define parameter array.
' Redim for two dimensions: name, value.
ReDim Parameter(0 To 2, 0 To 1)
' Parameter names.
Parameter(0, ParameterDetail.Name) = "q"
Parameter(1, ParameterDetail.Name) = "compact"
Parameter(2, ParameterDetail.Name) = "apiKey"
' Parameter values.
Parameter(0, ParameterDetail.Value) = CodePair
Parameter(1, ParameterDetail.Value) = CompactStyle
Parameter(2, ParameterDetail.Value) = CcaApiId
' Assemble parameters.
ReDim Parameters(LBound(Parameter, 1) To UBound(Parameter, 1))
For Index = LBound(Parameters) To UBound(Parameters)
Parameters(Index) = Parameter(Index, 0) & "=" & Parameter(Index, 1)
Next
' Assemble URL.
UrlParts(0) = Replace(ServiceUrl, TempSubdomain, Subdomain)
UrlParts(1) = Join(Parameters, "&")
Url = Join(UrlParts, "?")
' Uncomment for debugging.
'Debug.Print Url
' 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
If RetrieveDataResponse(Url, ResponseText) = True Then
Set DataCollection = CollectJson(ResponseText)
End If
If DataCollection Is Nothing Then
' Error. ResponseText holds the error code.
' Optional error handling.
Select Case ResponseText
Case HttpStatus.BadRequest
' Typical for invalid api key, or API limit reached.
Case EmptyResponse
' Invalid currency code.
Case Else
' Other error.
End Select
' Set "not found" return values.
Rates(0, RateDetail.Code) = NoCode
Rates(0, RateDetail.Rate) = NoRate
End If
If Not DataCollection Is Nothing Then
' The rate was retrieved.
' Get the UTC value date and time for the rate.
ValueDate = UtcNow
' The retrieved rate item is an array.
RateItem = DataCollection(RootNodeName)(CollectionItem.Data)(1)
Rates(0, RateDetail.Date) = ValueDate
Rates(0, RateDetail.Code) = Split(RateItem(CollectionItem.Name), "_")(1)
Rates(0, RateDetail.Rate) = RateItem(CollectionItem.Data)
' Store this code pair in the collection of code pairs.
CodePairs.Add Rates, CodePair
Set DataCollection = Nothing
' Round the call time down to the start of the update interval.
ThisCall = CDate(Fix(Now * 24 * 60 / UpdatePause) / (24 * 60 / UpdatePause))
' Record hour of retrieval.
LastCall = ThisCall
End If
' Record requested base currency.
LastCodePair = CodePair
End If
ExchangeRatesCca = Rates
End Function
As the exchange rates are collected pair-wise in the collection, the corresponding CurrencyConvertCca is extremely simple:
由于汇率是成对收集的，因此相应的CurrencyConvertCca非常简单：
' Returns the current conversion factor from one currency to another
' based on the exchange rates published by "Currency Converter API".
' By default, conversion is from Euro to another currency.
'
' If an invalid or unpublished currency code is passed, a conversion factor
' of zero is returned.
'
' Examples, typical:
' CurrencyConvertCca("DKK") -> 7.47139
' CurrencyConvertCca("DKK", "EUR") -> 7.47139
' CurrencyConvertCca("AUD") -> 1.61313
' CurrencyConvertCca("AUD", "DKK") -> 0.215908
' CurrencyConvertCca("DKK", "AUD") -> 4.63161
' CurrencyConvertCca("EUR", "DKK") -> 0.133844
' CurrencyConvertCca("", "DKK") -> 0.157527
' CurrencyConvertCca("USD") -> 1.176948
' Examples, neutral code.
' CurrencyConvertCca("AUD", "XXX") -> 1
' CurrencyConvertCca("XXX", "AUD") -> 1
' CurrencyConvertCca("XXX") -> 1
' Examples, invalid code.
' CurrencyConvertCca("XYZ") -> 0
' CurrencyConvertCca("DKK", "XYZ") -> 0
'
' 2018-09-24. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function CurrencyConvertCca( _
ByVal IsoTo As String, _
Optional ByVal IsoFrom As String = EuroCode) _
As Double
Dim Rates() As Variant
Dim IsoBase As String
Dim Factor As Double
If IsoFrom = "" Then
IsoFrom = EuroCode
End If
If IsoTo = "" Then
IsoTo = USDollarCode
End If
If IsoTo = NeutralCode Or IsoFrom = NeutralCode Then
Factor = NeutralRate
ElseIf IsoTo = IsoFrom Then
Factor = NeutralRate
Else
' Retrieve the current rate.
IsoBase = IsoFrom
Rates() = ExchangeRatesCca(IsoBase, IsoTo)
Factor = Rates(0, RateDetail.Rate)
End If
CurrencyConvertCca = Factor
End Function
5. Currencylayer API (5. Currencylayer API)
6. ExchangeRate API (6. ExchangeRate API)
7.固定器 (7. Fixer)
8.开放汇率 (8. Open Exchange Rates)
9. php.mk-北马其顿共和国国家银行 (9. php.mk - National Bank of the Republic of North Macedonia)
These five services supply the exchange rates as Json data. However, the formats of the four sets of data - as well as the formats of the URL to request these, and the possible error codes - are all different, thus individualised functions are needed to retrieve the exchange rates.
这五个服务将汇率作为Json数据提供。 但是，四组数据的格式以及请求这些格式的URL的格式以及可能的错误代码都不同，因此需要个性化的功能来检索汇率。
That said, they are quite similar, so we will only list one here. Note please, that - for free - only ExchangeRate API offers exchanges rates for any base currency, thus - for the four others - the exchange rates for other base currencies then the fixed one, triangular calculation is implemented to still obtain useful exchange rates using a free plan/subscription.
也就是说，它们非常相似，因此我们仅在此处列出一个。 请注意，（免费）只有ExchangeRate API提供任何基础货币的汇率，因此-对于其他四种-其他基础货币的汇率，则采用固定的一种三角计算 ，以仍然使用免费计划/订阅。
Other than that, the steps followed are similar to the other ExchangeRatesXyz function.
除此之外，遵循的步骤与其他ExchangeRatesXyz函数相似。
Note the second call to the service, in case an "invalid" base currency is passed - which will be the case using the free plan and a base currency other than the fixed:
请注意第二次调用该服务，以防万一传递了“无效”基础货币-使用免费计划和固定货币以外的基础货币时，情况会如此：
' Retrieve the current exchange rates from "Currencylayer API" for one base currency.
' The rates are returned as an array and cached until the next update.
' The rates are updated from once per hour down to once per minute.
'
' Default base currency is USD.
' For the free plan, exchange rates for other base currencies are
' calculated from USD by triangular calculation.
'
' Source:
' https://currencylayer.com/
' https://currencylayer.com/documentation
'
' Note:
' Exchange rates are classed as indicative rates and are accurate enough to display price estimations.
' The rates are unsuitable for forex trading or processing cross currency settlements.
'
' Example:
' Dim Rates As Variant
' Rates = ExchangeRatesCla()
' Rates(12, 0) -> 2018-09-20 08:54:06 ' Publishing date.
' Rates(12, 1) -> "BDT" ' Currency code.
' Rates(12, 2) -> 84.064038 ' Exchange rate.
'
' 2018-10-07. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function ExchangeRatesCla( _
Optional ByVal IsoBase As String) _
As Variant
' Operational constants.
'
' API endpoint for the free plan.
' For the paid plans, https may be used.
Const ServiceUrl As String = "http://www.apilayer.net/api/live"
' Update interval: 60, 10, or 1 minutes.
Const UpdatePause As Integer = 60
' Function constants.
'
' Default base currency code.
Const DefaultBase As String = USDollarCode
' Node names in retrieved collection.
Const RootNodeName As String = "root"
Const TimeNodeName As String = "timestamp"
Const RateNodeName As String = "quotes"
Const FirstNodeName As String = "success"
Const ErrorNodeName As String = "error"
Const CodeNodeName As String = "code"
' Error code for invalid or missing access key.
Const KeyErrorCode As Long = 101
' Error code for restricted access to base currency.
Const BaseErrorCode As Long = 105
' Error code for invalid currency code.
Const CodeErrorCode As Long = 201
Static Rates() As Variant
Static LastCode As String
Static LastCall As Date
Dim DataCollection As Collection
Dim Parameters() As String
Dim Parameter() As String
Dim UrlParts(1) As String
Dim RateCount As Integer
Dim RateItem As Variant
Dim BaseRate As Double
Dim Index As Integer
Dim Url As String
Dim ResponseText As String
Dim ValueDate As Date
Dim ThisCall As Date
Dim ErrorCode As Long
If IsoBase = "" Then
IsoBase = DefaultBase
End If
If LastCode = IsoBase And DateDiff("n", LastCall, Now) < UpdatePause Then
' Return cached rates.
Else
' Retrieve updated rates.
' Define parameter array.
' Redim for two dimensions: name, value.
ReDim Parameter(0 To 1, 0 To 1)
' Parameter names.
Parameter(0, ParameterDetail.Name) = "access_key"
Parameter(1, ParameterDetail.Name) = "source"
' Parameter values.
Parameter(0, ParameterDetail.Value) = ApiApiId
Parameter(1, ParameterDetail.Value) = IsoBase
' Assemble parameters.
ReDim Parameters(LBound(Parameter, 1) To UBound(Parameter, 1))
For Index = LBound(Parameters) To UBound(Parameters)
Parameters(Index) = Parameter(Index, 0) & "=" & Parameter(Index, 1)
Next
' Assemble URL.
UrlParts(0) = ServiceUrl
UrlParts(1) = Join(Parameters, "&")
Url = Join(UrlParts, "?")
' Uncomment for debugging.
' Debug.Print Url
' 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
If RetrieveDataResponse(Url, ResponseText) = True Then
Set DataCollection = CollectJson(ResponseText)
Else
' Give up.
Set DataCollection = Nothing
End If
If Not DataCollection Is Nothing Then
If DataCollection(RootNodeName)(CollectionItem.Data)(1)(CollectionItem.Name) = FirstNodeName Then
If DataCollection(RootNodeName)(CollectionItem.Data)(FirstNodeName)(CollectionItem.Data) = False Then
ErrorCode = DataCollection(RootNodeName)(CollectionItem.Data)(ErrorNodeName)(CollectionItem.Data)(CodeNodeName)(CollectionItem.Data)
Select Case ErrorCode
Case KeyErrorCode
' Missing or invalid access key.
Set DataCollection = Nothing
Case CodeErrorCode, BaseErrorCode
' Typical for invalid currency code, or if free license and base <> USD, respectively.
' Rebuld Url to use base = USD.
Parameter(1, 1) = DefaultBase
' Reassemble parameters.
For Index = LBound(Parameters) To UBound(Parameters)
Parameters(Index) = Parameter(Index, 0) & "=" & Parameter(Index, 1)
Next
' Reassemble URL.
UrlParts(0) = ServiceUrl
UrlParts(1) = Join(Parameters, "&")
Url = Join(UrlParts, "?")
' Try once more to retrieve the rates.
If RetrieveDataResponse(Url, ResponseText) = True Then
Set DataCollection = CollectJson(ResponseText)
If DataCollection(RootNodeName)(CollectionItem.Data)(FirstNodeName)(CollectionItem.Data) = False Then
' Give up.
Set DataCollection = Nothing
End If
End If
' Rebuld Url to use base = USD.
Parameter(1, 1) = DefaultBase
' Reassemble parameters.
For Index = LBound(Parameters) To UBound(Parameters)
Parameters(Index) = Parameter(Index, 0) & "=" & Parameter(Index, 1)
Next
' Reassemble URL.
UrlParts(0) = ServiceUrl
UrlParts(1) = Join(Parameters, "&")
Url = Join(UrlParts, "?")
' Try once more to retrieve the rates.
If RetrieveDataResponse(Url, ResponseText) = True Then
Set DataCollection = CollectJson(ResponseText)
If DataCollection(RootNodeName)(CollectionItem.Data)(FirstNodeName)(CollectionItem.Data) = False Then
' Give up.
Set DataCollection = Nothing
End If
End If
End Select
End If
End If
End If
If Not DataCollection Is Nothing Then
' Rates were retrieved.
' Get the UTC value date and time for the rates.
ValueDate = DateUnix(DataCollection(RootNodeName)(CollectionItem.Data)(TimeNodeName)(CollectionItem.Data))
' Get count of rates.
RateCount = DataCollection(RootNodeName)(CollectionItem.Data)(RateNodeName)(CollectionItem.Data).Count
' Redim for three dimensions: date, code, rate.
ReDim Rates(RateCount - 1, 0 To 2)
BaseRate = NeutralRate
' Fill the array from the collection items.
For Index = 1 To RateCount
' A retrieved rate item is an array.
RateItem = DataCollection(RootNodeName)(CollectionItem.Data)(RateNodeName)(CollectionItem.Data)(Index)
Rates(Index - 1, RateDetail.Date) = ValueDate
Rates(Index - 1, RateDetail.Code) = Right(RateItem(CollectionItem.Name), 3)
Rates(Index - 1, RateDetail.Rate) = RateItem(CollectionItem.Data)
If Right(RateItem(CollectionItem.Name), 3) = IsoBase And RateItem(CollectionItem.Data) <> NeutralRate Then
' Prepare triangular calculation.
BaseRate = RateItem(CollectionItem.Data)
End If
Next
If BaseRate <> NeutralRate Then
For Index = 1 To RateCount
' Perform triangular calculation of the exchange rates.
If Rates(Index - 1, RateDetail.Code) = IsoBase Then
Rates(Index - 1, RateDetail.Rate) = NeutralRate
Else
Rates(Index - 1, RateDetail.Rate) = Rates(Index - 1, RateDetail.Rate) / BaseRate
End If
Next
End If
Set DataCollection = Nothing
' Round the call time down to the start of the update interval.
ThisCall = CDate(Fix(Now * 24 * 60 / UpdatePause) / (24 * 60 / UpdatePause))
' Record requested base currency and hour of retrieval.
LastCode = IsoBase
LastCall = ThisCall
End If
End If
ExchangeRatesCla = Rates
End Function
The matching ConvertCurrencyXyz functions are similar to the first listed above, so please go to the code to study the minor differences.
匹配的ConvertCurrencyXyz函数类似于上面列出的第一个函数，因此请转到代码以研究较小的差异。
10. XE (10. XE)
The API of the XE service is extended compared to the other services - for example, are average exchange rates for a period offered. That comes for a price, as no free plan is offered. If you only wish to check it out, obtain a free trial, and you have seven days; from then on, you'll have to pay.
与其他服务相比，XE服务的API有所扩展-例如，所提供时间段内的平均汇率。 这是有代价的，因为没有提供免费计划。 如果您只想检查一下，请获得免费试用，并且您有7天的时间； 从那时起，您将需要付费。
Due to the complexity of the API, our ExchangeRatesXec function is slightly extended compared to the other functions handling Json data, because the retrieved data contains not only exchange rates but sets of exchange rates for each currency. To make the function comparable to the other ExchangeRateXyz functions, we only deal with the mid-market rates, but still.
由于API的复杂性，我们ExchangeRatesXec功能略有延长相对于其他功能处理JSON数据，因为检索到的数据不仅包含各种货币兑换汇率的利率，但套 。 为了使该功能与其他ExchangeRateXyz功能具有可比性，我们仅处理中端市场汇率，但仍然如此。
Anyway, if you have the budget and a need for some of the more special options and offerings from XE, the function here will provide a good starting point.
无论如何，如果您有预算并且需要XE的一些更特殊的选项和产品，则此处的功能将为您提供一个良好的起点。
As for the other functions, the in-line comments will guide you through the steps taken:
至于其他功能，在线注释将指导您完成以下步骤：
' Retrieve the current exchange rates from "XE" for one base currency.
' The rates are returned as an array and cached until the next update.
' The rates are updated from once per day down to once per minute.
'
' Default base currency is USD.
'
' Source:
' https://www.xe.com/
' https://www.xe.com/xecurrencydata/
'
' Note:
' Exchange rates are live mid-market rates, which are not available to
' consumers and are for informational purposes only.
'
' Example:
' Dim Rates As Variant
' Rates = ExchangeRatesXec()
' Rates(12, 0) -> 2018-10-12 00:00:00 ' Publishing date.
' Rates(12, 1) -> "BDT" ' Currency code.
' Rates(12, 2) -> 83.7886823907 ' Exchange rate.
'
' 2018-10-16. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function ExchangeRatesXec( _
Optional ByVal IsoBase As String) _
As Variant
' Operational constants.
'
' API endpoint.
Const ServiceUrl As String = "https://xecdapi.xe.com/v1/convert_from/"
' Update interval: 60, 30, or 5 minutes.
Const UpdatePause As Integer = 60
' Function constants.
'
' Default base currency code.
Const DefaultBase As String = USDollarCode
' Node names in retrieved collection.
Const RootNodeName As String = "root"
Const TimeNodeName As String = "timestamp"
Const RateNodeName As String = "to"
Const CodeNodeName As String = "quotecurrency"
Const ValueNodeName As String = "mid"
Static Rates() As Variant
Static LastCode As String
Static LastCall As Date
Dim DataCollection As Collection
Dim Parameter() As String
Dim Parameters() As String
Dim UrlParts(1) As String
Dim UserName As String
Dim Password As String
Dim RateCount As Integer
Dim RateItem As Variant
Dim BaseRate As Double
Dim Index As Integer
Dim Url As String
Dim ResponseText As String
Dim ValueDate As Date
Dim ThisCall As Date
If IsoBase = "" Then
IsoBase = DefaultBase
End If
If LastCode = IsoBase And DateDiff("n", LastCall, UtcNow) < UpdatePause Then
' Return cached rates.
Else
' Retrieve updated rates.
' Define parameter array.
' Redim for two dimensions: name, value.
ReDim Parameter(0 To 1, 0 To 1)
' Parameter names.
Parameter(0, ParameterDetail.Name) = "from"
Parameter(1, ParameterDetail.Name) = "to"
' Parameter values.
Parameter(0, ParameterDetail.Value) = IsoBase
Parameter(1, ParameterDetail.Value) = "*"
' Assemble parameters.
ReDim Parameters(LBound(Parameter, 1) To UBound(Parameter, 1))
For Index = LBound(Parameters) To UBound(Parameters)
Parameters(Index) = Parameter(Index, 0) & "=" & Parameter(Index, 1)
Next
' Assemble URL.
UrlParts(0) = ServiceUrl
UrlParts(1) = Join(Parameters, "&")
Url = Join(UrlParts, "?")
' Uncomment for debugging.
Debug.Print Url
' Credentials.
UserName = XeAccount
Password = XeApiId
' 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
If RetrieveDataResponse(Url, ResponseText, , UserName, Password) = True Then
Set DataCollection = CollectJson(ResponseText)
Else
' Check error codes.
Select Case Left(ResponseText, 3)
Case HttpStatus.Forbidden
' Invalid credentials.
Case HttpStatus.BadRequest
' Invalid currency code (typical).
End Select
' No rates were received.
Set DataCollection = Nothing
End If
If Not DataCollection Is Nothing Then
' Rates were retrieved.
' Get the UTC value date and time for the rates.
ValueDate = DateIso8601(DataCollection(RootNodeName)(CollectionItem.Data)(TimeNodeName)(CollectionItem.Data))
' Get count of rates.
RateCount = DataCollection(RootNodeName)(CollectionItem.Data)(RateNodeName)(CollectionItem.Data).Count
' Redim for three dimensions: date, code, rate.
ReDim Rates(RateCount - 1, 0 To 2)
BaseRate = NeutralRate
' Fill the array from the collection items.
For Index = 1 To RateCount
' A retrieved rate item is yet a collection with an array.
RateItem = DataCollection(RootNodeName)(CollectionItem.Data)(RateNodeName)(CollectionItem.Data)(Index)
Rates(Index - 1, RateDetail.Date) = ValueDate
Rates(Index - 1, RateDetail.Code) = RateItem(CollectionItem.Data)(CodeNodeName)(CollectionItem.Data)
Rates(Index - 1, RateDetail.Rate) = RateItem(CollectionItem.Data)(ValueNodeName)(CollectionItem.Data)
Next
Set DataCollection = Nothing
' Round the call time down to the start of the update interval.
ThisCall = CDate(Fix(Now * 24 * 60 / UpdatePause) / (24 * 60 / UpdatePause))
' Record requested base currency and hour of retrieval.
LastCode = IsoBase
LastCall = ThisCall
End If
End If
ExchangeRatesXec = Rates
End Function
The accompanying CurrencyConvertXec function is similar to the other CurrencyConvertXyz functions, so I won't list it here.
随附的CurrencyConvertXec函数与其他CurrencyConvertXyz函数类似，因此在此不再列出。
配套功能 (Supporting functions)
A few trivial supporting date functions are used in some of the exchange rate functions. They will not be listed here, but can all be found in the supplemental modules included in the repository and the attached demo application.
一些汇率函数中使用了一些琐碎的支持日期函数。 它们不会在此处列出，但是都可以在存储库和随附的演示应用程序中包含的补充模块中找到。
储存汇率 (Storing exchange rates)
In many cases, you will simply wish to maintain a table with current (and past) exchange rates.
在许多情况下，您仅希望维护一个包含当前（和过去）汇率的表格。
This can easily be done - using the array of rates returned from any of the ExchangeRatesXyz functions.
这很容易完成-使用从任何ExchangeRatesXyz函数返回的汇率数组。
A simple function, that demonstrates this, is included - either to be used as is or for a starting point:
包含一个简单的函数来演示这一点-可以按原样使用或用作起点：
' CurrencyExchange Demo V1.0.0
' (c) Gustav Brock, Cactus Data ApS, CPH
' Fill table CurrencyRate with exchange rates from a source of choice.
'
' Example:
'
' FillCurrencyRates ExchangeRatesDkk
'
' Note, that some sources don't supply the currency name, only the code.
'
' 2018-10-07. Gustav Brock, Cactus Data ApS, CPH.
'
Public Sub FillCurrencyRates(ByRef Rates As Variant)
Const TableName As String = "CurrencyRate"
Dim Records As DAO.Recordset
Dim FieldNames As Variant
Dim Sql As String
Dim Index As Integer
Dim Item As Integer
If Not IsArray(Rates) Then Exit Sub
' Field names must match the order of array Rates.
FieldNames = Array("[Date]", "[Code]", "[Rate]", "[Name]")
' Clean table.
Sql = "Delete * From " & TableName & ";"
CurrentDb.Execute Sql
' Fill table.
Sql = "Select " & Join(FieldNames, ",") & " From " & TableName & ";"
Set Records = CurrentDb.OpenRecordset(Sql)
For Index = LBound(Rates, 1) To UBound(Rates, 1)
Records.AddNew
For Item = LBound(Rates, 2) To UBound(Rates, 2)
Records.Fields(Item).Value = Rates(Index, Item)
Next
Records.Update
Next
Records.Close
End Sub
A table for the purpose, CurrencyRate, is included as well for you to check out.
还包括一个目的表CurrencyRate ，供您签出。
结论 (Conclusion)
Extensive code has been provided for retrieving, using, and storing currency exchange rates from nine different sources - some free, some paid - using three basic methods for reading data off the internet.
提供了广泛的代码，用于使用三种基本方法从Internet上读取，检索和使用九种不同来源的货币汇率，其中一些是免费的，有些是付费的。
As more services may become available, it should be easy to modify one or more of these functions to match a new service.
随着更多服务的可用，应该容易地修改这些功能中的一个或多个功能以匹配新服务。
进一步阅读 (Further reading)
My previous article about currency may prove useful: ISO 4217 Currency Codes in VBA
我以前有关货币的文章可能被证明是有用的： VBA中的ISO 4217货币代码
代码模块和演示应用程序 (Code modules and demo application)
Code has been tested with both 32-bit and 64-bit Microsoft Access 2019 and 365.
代码已通过32位和64位Microsoft Access 2019和365进行了测试 。
Please note, that it requires the Json modules from project VBA.CVRAPI.
请注意，它需要项目VBA.CVRAPI中的Json模块 。
A demo in Microsoft Access 2019 is attached: CurrencyExchange 1.6.0.zip
随附Microsoft Access 2019中的演示： CurrencyExchange 1.6.0.zip
The current code can at any time be obtained from GitHub: VBA.CurrencyExchange
当前代码可以随时从GitHub获得： VBA.CurrencyExchange
I hope you found this article useful. You are encouraged to ask questions, report any bugs or make any other comments about it below.
希望本文对您有所帮助。 鼓励您在下面提出问题，报告任何错误或对此作出任何其他评论。
Note: If you need further "Support" about this topic, please consider using the Ask a Question feature of Experts Exchange. I monitor questions asked and would be pleased to provide any additional support required in questions asked in this manner, along with other EE experts.
注意 ：如果您需要有关此主题的更多“支持”，请考虑使用Experts Exchange 的“提问”功能。 我会监督提出的问题，并很高兴与其他电子工程师一起为以这种方式提出的问题提供所需的任何其他支持。
Please do not forget to press the "Thumbs Up" button if you think this article was helpful and valuable for EE members.
如果您认为本文对EE成员有用且有价值，请不要忘记按下“竖起大拇指”按钮。
翻译自: https://www.experts-exchange.com/articles/33199/Exchange-Rates-and-Currency-Conversion-in-VBA.html
vba 时间换算
扫一扫
885
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
