ISO 4217 Currency Codes in VBA

Gustav BrockMVP
CERTIFIED EXPERT
Published:
Updated:
Edited by: Andrew Leniart
Currency codes can be obtained from many sources. The modules here retrieve them from two sources: ISO itself (the definitive source) and Currency Converter API. Both methods will allow you to maintain a table of current currency codes.

ISO - the definitive source


ISO is the organisation that maintains the official list of currency codes, known as the ISO 4217 standard:


Currency codes - ISO 4217


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:


Supplemental tools


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.


Currency Converter API - the handy source


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:


Currency Converter API


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.


Supplemental tools


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



Conclusion


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.


Exchange Rates

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

1
2,737 Views
Gustav BrockMVP
CERTIFIED EXPERT

Comments (0)

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.