本文介绍了如何在VBA中使用ISO 4217标准管理和更新货币代码，包括从官方XML源下载新数据、转换货币代码与编号，以及利用货币转换器API。此外，还提供了相关的辅助工具和示例应用程序。
vba货币小写引大写的程序
ISO-权威来源 (ISO - the definitive source)
ISO is the organisation that maintains the official list of currency codes, known as the ISO 4217 standard:
ISO是维护官方货币代码清单（称为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.
与ISO维护的大多数标准相反，货币代码列表可以作为XML文件免费下载，这就是代码的作用。
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:
该函数使用Microsoft XML v6.0读取XML文件和发布日期：
' 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:
更新函数将维护一个具有CcyNtry奇怪名称的表 （来自XML文件）。 因此，包含了一个查询Iso4217CurrencyCode ，该查询返回带有有意义字段名称的经过净化的货币代码列表：
补充工具 (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.
尽管很少使用货币号，但是您有一天可能会需要它，然后这些功能将很有用。
货币转换器API-方便的来源 (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.
尽管正式的ISO 4217清单（按定义）是完整的，但它还包含几种很少使用的货币，您甚至无法获得其每日汇率。
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:
因此，提供了另一种维护货币代码列表的方法，该方法检索由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.
该列表以JSON数据的形式提供，与XML文件相比，在VBA中读取和解码所需的时间更多。
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.
创建用于获取列表的函数使用VBA.CVRAPI项目中的Json模块将数据读取到集合中，并将列表作为数组返回。
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:
再次，这些步骤由内嵌注释仔细记录在案。 请注意用于避免重复调用该服务的变量LastCall ：
' 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:
函数UpdateCurrencyCodes中使用此函数来维护表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.
该表的结构允许存储历史（过时）货币代码。 查询可用， CcaCurrencyCode仅返回当前代码。
补充工具 (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:
在那些您可能希望检查某些货币代码是否存在的情况下，将创建一个微型函数，该函数通过在查询CcaCurrencyCode中查找所传递的代码是否存在（但不是过时的）来检查该代码，以过滤出过时的：
' 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.
代码已通过32位和64位Microsoft Access 2016和365进行了测试 。
Please note, that it requires the Json modules from project VBA.CVRAPI.
请注意，它需要项目VBA.CVRAPI中的Json模块 。
A demo in Microsoft Access 2016 is attached: CurrencyCode 1.1.1.zip
随附Microsoft Access 2016中的演示： CurrencyCode 1.1.1.zip
The current code can at any time be obtained from GitHub: VBA.CurrencyCode
当前代码可随时从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.
注意 ：如果您需要有关此主题的更多“支持”，请考虑使用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/33162/ISO-4217-Currency-Codes-in-VBA.html
vba货币小写引大写的程序
扫一扫
2270
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
