<

Exchange Rates and Currency Conversion in VBA

Published on
5,585 Points
1,585 Views
Last Modified:
When converting amounts between different currencies, you need exchange rates. This article demonstrates how to obtain these from no less than nine different sources, either for free or - for intense or demanding use - for a fee.

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

2. The Danish National Bank

3. The Central Bank of the Russian Federation

4. Currency Converter API

5. Currencylayer API

6. ExchangeRate API

7. Fixer

8. Open Exchange Rates

9. 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.


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:


  1. addressing an API, delivering data as Json
  2. reading an XML document
  3. parsing an HTML document (web scraping, data extracting)


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


where Xyz is a three-letter abbreviation of the service name.


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:


  1. Publishing date (Date)
  2. ISO currency code (Three-letter string)
  3. Exchange rate (Double)
  4. (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


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. 


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.


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.


The Json modules from the project VBA.CVRAPI are required for those functions that retrieve data as Json.


The services


1. The European Central Bank

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. 


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.


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.


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. 


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.


"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).


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.


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. 


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.


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):


' 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:


' 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

6. ExchangeRate API

7. Fixer

8. Open Exchange Rates


These four 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.


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 three 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. 


Other than that, the steps followed are similar to the other ExchangeRatesXyz function.


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.


9. 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.


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.


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.


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.


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.

A simple function, that demonstrates this, is included - either to be used as is or for a starting point:


' 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.


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.


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


Code modules and demo application

 

Code has been tested with both 32-bit and 64-bit Microsoft Access 2016 and 365

Please note, that it requires the Json modules from project VBA.CVRAPI.

 

A demo in Microsoft Access 2016 is attached: CurrencyExchange 1.5.3.zip

 

The current code can at any time be obtained from 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.


Please do not forget to press the "Thumbs Up" button if you think this article was helpful and valuable for EE members.


0
Ask questions about what you read
If you have a question about something within an article, you can receive help directly from the article author. Experts Exchange article authors are available to answer questions and further the discussion.
Get 7 days free