ISO is the organisation that maintains the official list of currency codes, known as the ISO 4217 standard:
Contrary to most of the standards maintained by ISO, the list of currency codes is free to download as an XML file, and this is what the code does.
As the list is only rarely updated before a download is attempted, the publishing date is checked - and only if it is newer than the date of the last download, the list is downloaded.
The function uses Microsoft XML, v6.0 to read the XML file and the publishing date:
' Retrieve the current publishing date for the ISO 4217 currency codes.
'
' 2018-08-17. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function Iso4217PublishingDate() As Date
' Function constants.
'
' Async setting.
Const Async As Variant = False
' XML node and attribute names.
Const RootNodeName As String = "ISO_4217"
Const DateItemName As String = "Pblshd"
#If EarlyBinding Then
' Microsoft XML, v6.0.
Dim Document As MSXML2.DOMDocument60
Dim XmlHttp As MSXML2.XMLHTTP60
Dim RootNodeList As MSXML2.IXMLDOMNodeList
Dim RootNode As MSXML2.IXMLDOMNode
Set Document = New MSXML2.DOMDocument60
Set XmlHttp = New MSXML2.XMLHTTP60
#Else
Dim Document As Object
Dim XmlHttp As Object
Dim RootNodeList As Object
Dim RootNode As Object
Set Document = CreateObject("MSXML2.DOMDocument")
Set XmlHttp = CreateObject("MSXML2.XMLHTTP")
#End If
Static LastChecked As Date
Static ValueDate As Date
Dim Url As String
If DateDiff("d", LastChecked, Date) <= 0 Then
' ValueDate has been retrieved recently.
' Don't check again until tomorrow.
Else
' Retrieve current status.
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
' Set update date.
ValueDate = CDate(RootNode.Attributes.getNamedItem(DateItemName).nodeValue)
' Set check date.
LastChecked = Date
End If
End If
End If
Set XmlHttp = Nothing
Set Document = Nothing
Iso4217PublishingDate = ValueDate
End Function
To avoid using a table to store this single value, the publishing date is stored as a property of the database.
The value of this is saved or read with a single function:
' Set or get the date of the last published list of ISO 4217 currency codes
' using a property of CurrentProject.
'
' Example:
' PublishingDate = #2020/01/10#
' ' Set
' ? LastPublishingDate(PublishingDate) -> 2020-01-10 00:00:00
' ' Get
' ? LastPublishingDate() -> 2020-01-10 00:00:00
'
' 2018-08-17. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function LastPublishingDate( _
Optional ByVal NewPublishingDate As Date) _
As Date
Const PropertyName As String = "Iso4217PublishingDate"
Dim StoredUpdate As AccessObjectProperty
Dim Index As Integer
Dim PublishingDate As Date
Dim PublishingValue As String
' The property cannot hold a Date value.
' Convert NewPublishingDate to a string expression.
PublishingValue = Format(NewPublishingDate, "yyyy\-mm\-dd hh\:nn\:ss")
For Index = 0 To CurrentProject.Properties.Count - 1
If CurrentProject.Properties(Index).Name = PropertyName Then
' The property exists.
Set StoredUpdate = CurrentProject.Properties(Index)
End If
Next
If StoredUpdate Is Nothing Then
' This property has not be created.
' Create it with the value of PublishingValue.
CurrentProject.Properties.Add PropertyName, PublishingValue
Set StoredUpdate = CurrentProject.Properties(PropertyName)
ElseIf CDate(PublishingValue) > #12:00:00 AM# Then
' Set value of property.
StoredUpdate.Value = PublishingValue
ElseIf Not IsDate(StoredUpdate.Value) Then
' For some reason, the property is not holding a date expression.
' Reset the value.
StoredUpdate.Value = PublishingValue
End If
' Read the stored string expression and convert to a date value.
PublishingDate = CDate(StoredUpdate.Value)
LastPublishingDate = PublishingDate
End Function
Having the above two functions ready, it is now a snap to download the list of currency codes only when new data is present. The in-line comments explain the flow:
' Create or update a table holding the current and complete list of
' currency codes and numbers according to ISO 4217.
' Data are retrieved directly from the source.
'
' A list of unique codes and numbers can be retrieved with this query:
'
' SELECT DISTINCT
' Ccy AS Code, CcyNbr AS [Number], CcyNm AS Name
' FROM
' CcyNtry
' WHERE
' Ccy Is Not Null;
'
'
' 2018-08-17. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function UpdateIso4217() As Boolean
Dim TableDef As DAO.TableDef
Dim ImportOptions As AcImportXMLOption
Dim Sql As String
Dim Url As String
Dim LastPublished As Date
Dim PublishingDate As Date
Dim Result As Boolean
' Retrieve current publishing date.
PublishingDate = Iso4217PublishingDate
' Retrive publishing date of table.
LastPublished = LastPublishingDate()
' Check if new data have been published.
If DateDiff("d", LastPublished, PublishingDate) = 0 Then
' Currency code table is current.
Result = True
Else
' Update currency table.
For Each TableDef In CurrentDb.TableDefs
If TableDef.Name = TableName Then
ImportOptions = acAppendData
Exit For
End If
Next
If ImportOptions = acAppendData Then
' Clear current list.
Sql = "Delete From " & TableName
CurrentDb.Execute Sql
Else
' First time import.
ImportOptions = acStructureAndData
End If
' Fetch the current list and append it to the (empty) table.
Url = ServiceUrl & Filename
On Error Resume Next
Application.ImportXML Url, ImportOptions
' Return success if no error.
If Not CBool(Err.Number) Then
Result = True
' Store the current publishing date to avoid repeated calls.
LastPublishingDate PublishingDate
End If
End If
UpdateIso4217 = Result
End Function
The update function will maintain a table with the weird name of CcyNtry (from the XML file). Thus a query, Iso4217CurrencyCode, is included which returns a sanitised list of the currency codes with meaningful field names:
As the code list and the imported table both contain the Currency Code, as well as the Currency Number, a set of functions to convert between these, is included:
' Retrieve the ISO 4217 currency code matching an ISO 4217 currency number.
'
' An empty string will be returned is the currency number is not found, or
' a default currency code can be specified for not found currency numbers.
'
' Examples:
' ? CurrencyCode("978") -> "EUR"
' ? CurrencyCode("000") -> ""
' ? CurrencyCode("000", "XXX") -> "XXX"
'
' 2018-08-17. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function CurrencyCode( _
ByVal CurrencyNumber As String, _
Optional ByVal DefaultCode As String) _
As String
' Field names.
Const CodeFieldName As String = "Ccy"
Const NumberFieldName As String = "CcyNbr"
Static Number As String
Static Code As String
If Number <> CurrencyNumber & DefaultCode Then
Code = Nz(DLookup(CodeFieldName, TableName, NumberFieldName & " = '" & CurrencyNumber & "'"), DefaultCode)
Number = CurrencyNumber & DefaultCode
End If
CurrencyCode = Code
End Function
' Retrieve the ISO 4217 currency number matching an ISO 4217 currency code.
'
' An empty string will be returned is the currency code is not found, or
' a default currency number can be specified for not found currency codes.
'
' Examples:
' ? CurrencyNumber("EUR") -> "978"
' ? CurrencyNumber("ZZZ") -> ""
' ? CurrencyNumber("ZZZ", "999") -> "999"
'
' 2018-08-17. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function CurrencyNumber( _
ByVal CurrencyCode As String, _
Optional ByVal DefaultNumber As String) _
As String
' Field names.
Const CodeFieldName As String = "Ccy"
Const NumberFieldName As String = "CcyNbr"
Static Number As String
Static Code As String
If Code <> CurrencyCode & DefaultNumber Then
Number = Nz(DLookup(NumberFieldName, TableName, CodeFieldName & " = '" & CurrencyCode & "'"), DefaultNumber)
Code = CurrencyCode & DefaultNumber
End If
CurrencyNumber = Number
End Function
Though the currency number is rarely used, you may need it someday, and then these functions will be useful.
While the official ISO 4217 list is - per definition - complete, it also contains several rarely used currencies for which you may not even be able to obtain a daily exchange rate.
For this reason, another method for maintaining a list of currency codes is offered, which retrieves the currency code list offered and published by Manuel Vergel:
It is free to use in a fair manner. For extensive use, you should sign up and create a paid account.
The list is supplied as JSON data which takes a lot more in VBA to read and decode than an XML file does.
The function created to fetch the list uses the Json modules from my VBA.CVRAPI project to read the data into a collection and return the list as an array.
Again, the steps are carefully documented by the in-line comments. Note the variable LastCall that is used to avoid repeated calls to the service:
' Retrieve the current currency code list from Currency Converter API.
' The list is returned as an array and cached until the next update.
'
' Source:
' https://currencyconverterapi.com/
' https://currencyconverterapi.com/docs
'
' Note:
' The services are provided as is and without warranty.
'
' Example:
' Dim Codes As Variant
' Codes = ExchangeRatesCca()
' Codes(101, 0) -> CHF ' Currency code.
' Codes(101, 1) -> "Fr." ' Currency name.
' Codes(101, 2) -> "Swiss Franc" ' Currency name.
'
' 2018-09-24. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function CurrencyCodesCca() 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 & "/currencies"
' Update interval in minutes.
Const UpdatePause As Integer = 24 * 60
' Function constants.
'
' Node names in retrieved collection.
Const RootNodeName As String = "root"
Const ListNodeName As String = "results"
' ResponseText when invalid currency code is passed.
Const EmptyResponse As String = "{}"
' Field names.
Const CodeId As String = "id"
Const CodeName As String = "currencyName"
Const CodeSymbol As String = "currencySymbol"
Static CodePairs As Collection
Static Codes() As Variant
Static LastCall As Date
Dim DataCollection As Collection
Dim CodeCollection As Collection
Dim Parameter() As String
Dim Parameters() As String
Dim UrlParts(1) As String
Dim Subdomain As String
Dim CodeCount As Integer
Dim Index As Integer
Dim Item As Integer
Dim Value As String
Dim FieldCount As Integer
Dim Url As String
Dim ResponseText As String
Dim ValueDate As Date
Dim ThisCall As Date
Dim IsCurrent As Boolean
' Is the current collection of Codes up-to-date?
IsCurrent = DateDiff("n", LastCall, Now) < UpdatePause
If IsCurrent Then
' Return cached codes.
Else
' Retrieve the code pair and add it to the collection of code pairs.
' 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 0, 0 To 1)
' Parameter names.
Parameter(0, ParameterDetail.Name) = "apiKey"
' Parameter values.
Parameter(0, 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 a no-result array.
' Redim for three dimensions: code, symbol, name.
ReDim Codes(0, 0 To 2)
' Set "not found" return values.
Codes(0, CodeDetail.Code) = NeutralCode
Codes(0, CodeDetail.Name) = NeutralName
Codes(0, CodeDetail.Sign) = NeutralSign
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
End If
If Not DataCollection Is Nothing Then
If DataCollection(RootNodeName)(CollectionItem.Data)(1)(CollectionItem.Name) = ListNodeName Then
' The code list was retrieved.
' Get count of codes.
CodeCount = DataCollection(RootNodeName)(CollectionItem.Data)(ListNodeName)(CollectionItem.Data).Count
ReDim Codes(0 To CodeCount - 1, 0 To 2)
For Index = 1 To CodeCount
' The code information is a collection.
Set CodeCollection = DataCollection(RootNodeName)(CollectionItem.Data)(1)(CollectionItem.Data)(Index)(CollectionItem.Data)
FieldCount = CodeCollection.Count
' Fill one array item.
For Item = 1 To FieldCount
Value = CodeCollection(Item)(CollectionItem.Data)
Select Case CodeCollection(Item)(CollectionItem.Name)
Case CodeId
Codes(Index - 1, CodeDetail.Code) = Value
Case CodeName
Codes(Index - 1, CodeDetail.Name) = Value
Case CodeSymbol
Codes(Index - 1, CodeDetail.Sign) = Value
End Select
Next
Next
' 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
End If
End If
CurrencyCodesCca = Codes
End Function
This function is used in the function UpdateCurrencyCodes to maintain the table CurrencyCode:
' Retrieve and update the table holding the list of currency codes
' published by Currency Code API.
'
' 2018-09-24. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function UpdateCurrencyCodes() As Boolean
' Table and field names of table holding currency codes.
Const TableName As String = "CurrencyCode"
Const Field1 As String = "Code"
Const Field2 As String = "Name"
Const Field3 As String = "Symbol"
Const Field4 As String = "Assigned"
Const Field5 As String = "Unassigned"
Dim Records As DAO.Recordset
Dim Codes As Variant
Dim Item As Integer
Dim Sql As String
Dim Criteria As String
Dim Unassigned As Boolean
On Error GoTo Err_UpdateCurrencyCodes
' Retrieve array of current currency codes.
Codes = CurrencyCodesCca
Sql = "Select * From " & TableName & ""
Set Records = CurrentDb.OpenRecordset(Sql)
' Add new currency codes.
For Item = LBound(Codes, 1) To UBound(Codes, 1)
Criteria = "Code = '" & Codes(Item, CodeDetail.Code) & "'"
Records.FindFirst Criteria
If Records.NoMatch Then
' New currency code.
Records.AddNew
Records.Fields(Field1).Value = Codes(Item, CodeDetail.Code)
Records.Fields(Field2).Value = Codes(Item, CodeDetail.Name)
Records.Fields(Field3).Value = Codes(Item, CodeDetail.Sign)
Records.Fields(Field4).Value = Date
Records.Update
ElseIf Not IsNull(Records.Fields(Field5).Value) Then
' Existing currency code, marked as unassigned.
' Reassign.
Records.Edit
Records.Fields(Field4).Value = Date
Records.Fields(Field5).Value = Null
Records.Update
End If
Next
' Mark retracted currency codes as unassigned.
Records.MoveFirst
While Not Records.EOF
Unassigned = True
For Item = LBound(Codes, 1) To UBound(Codes, 1)
If Records.Fields("Code").Value = Codes(Item, CodeDetail.Code) Then
Unassigned = False
Exit For
End If
Next
If Unassigned Then
Records.Edit
Records.Fields("Unassigned").Value = Date
Records.Update
End If
Records.MoveNext
Wend
Records.Close
UpdateCurrencyCodes = True
Exit_UpdateCurrencyCodes:
Exit Function
Err_UpdateCurrencyCodes:
MsgBox "Error" & Str(Err.Number) & ": " & Err.Description, vbCritical + vbOKOnly, "Update Currency Codes"
Resume Exit_UpdateCurrencyCodes
End Function
The structure of the table allows for storing historical (obsolete) currency codes. A query is available, CcaCurrencyCode to return the current codes only.
In those cases where you may wish to check if some currency code exists, a tiny function has been created, which checks if a passed code exists - and is not obsolete - by looking it up in the query CcaCurrencyCode which filters out the codes that are obsolete:
' Check if a currency code is one of the listed currency codes
' published by Currency Code API.
'
' 2018-09-24. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function IsCurrencyCode( _
ByVal Code As String) _
As Boolean
' Table (or query) and field names of table holding currency codes.
Const TableName As String = "CcaCurrencyCode"
Const Field1 As String = "Code"
Dim Criteria As String
Dim Result As Boolean
Criteria = Field1 & " = '" & Code & "'"
Result = Not IsNull(DLookup(Field1, TableName, Criteria))
IsCurrencyCode = Result
End Function
Two different sources offering currency codes as well as methods for downloading and maintaining a list of currency codes have been demonstrated and should cover any need.
If your purpose for maintaining currency codes is related to currency exchange rates and currency conversion, don't miss my article:
Exchange Rates and Currency Conversion in VBA
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: CurrencyCode 1.1.1.zip
The current code can at any time be obtained from GitHub: VBA.CurrencyCode
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.
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (0)