VBA获取在线货币

Posted

技术标签:

【中文标题】VBA获取在线货币【英文标题】：VBA obtain online currency 【发布时间】：2019-11-27 01:28:29 【问题描述】：

最近我才意识到雅虎金融（.cs​​v）已被关闭，导致我无法在我的 excel 中进行在线货币（更新）。 因此，我尝试使用以下方法来完成我的工作。

1) 网址：http://www.google.com/search?q="A"+to+"B"/

2) 正如我所注意到的，货币汇率将显示在 div class="dDoNo vk_bk"

以下是我正在尝试做的工作。

Option Explicit

Function OnlineCurrency(current_country As String, to_country As String) As String
Dim HTTP As MSXML2.XMLHTTP60
Dim URL As String
Dim htmlDoc As New HTMLDocument
URL = "http://www.google.com/search?q=HKD+to+USD"
Set HTTP = New MSXML2.XMLHTTP60
HTTP.Open "GET", URL, False
HTTP.send
Set HTMLDoc = New HTMLDocument

With HTMLDoc
  .body.innerHTML = HTTP.responseText
  OnlineCurrency = .getElementByClassName("dDoNo vk_bk").innerText
End With

End Function

但我似乎无法展示任何相关内容。有人可以帮我/指出我的问题吗？谢谢

【问题讨论】：

由于拼写错误 current_country 以及 getElementByClass 不作为方法存在，因此对于初学者来说，上述内容会出错。请提供两个函数参数的测试值。根据 excel 版本，您可能还需要 Dim HTTP As MSXML2.XMLHTTP60 一个完整的 url 字符串示例也会有所帮助。并且绝对是指向您已经成功看到要检索的值的页面的链接 你可以试试这个网站：alphavantage.co. @PatrickHonorez 感谢您的建议，但我宁愿不使用 API 来调用数据。由于 API 有几个限制（例如每天 500 个请求），这可能会在未来造成麻烦。 @QHarr 感谢您的推荐，我应该在发布之前再次检查我的工作。有没有办法让我检查我是否已经使用上述编码连接到网站。 【参考方案1】：

提供currency rates for free的服务有很多。

如果您的目标是使用 UDF 获取/转换费率，请考虑缓存费率以避免因请求过多而被服务启动。

这是一个 UDF，它使用缓存有效地转换具有来自 European Central Bank 的汇率的货币（每日更新）：

''
' UDF to convert a currency using the daily updated rates fron the European Central Bank  '
'  =ConvCurrency(1, "USD", "GBP")                                                         '
''
Public Function ConvCurrency(Value, fromSymbol As String, toSymbol As String)
  Static rates As Collection, expiration As Date  ' cached / keeps the value between calls '

  If DateTime.Now > expiration Then
    Dim xhr As Object, node As Object
    expiration = DateTime.Now + DateTime.TimeSerial(1, 0, 0) ' + 1 hour '

    Set rates = New Collection
    rates.Add 1#, "EUR"

    Set xhr = CreateObject("Msxml2.ServerXMLHTTP.6.0")
    xhr.Open "GET", "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml", False
    xhr.Send

    For Each node In xhr.responseXML.SelectNodes("//*[@rate]")
      rates.Add Conversion.Val(node.GetAttribute("rate")), node.GetAttribute("currency")
    Next
  End If

  ConvCurrency = (Value / rates(fromSymbol)) * rates(toSymbol)
End Function

如果您更喜欢中端市场实时汇率，此示例采用来自 www.freeforexapi.com 的汇率

''
' UDF to convert a currency using the mid-market live rates from www.freeforexapi.com     '
'  =ConvCurrency(1, "USD", "GBP")                                                     '
''
Public Function ConvCurrency(Value, fromSymbol As String, toSymbol As String)
  Static rates As Collection, expiration As Date  ' cached / keeps the value between calls '

  Const SYMBOLS = "AED,AFN,ALL,AMD,ANG,AOA,ARS,ATS,AUD,AWG,AZM,AZN,BAM,BBD,BDT,BEF,BGN,BHD,BIF,BMD,BND,BOB,BRL,BSD,BTN,BWP,BYN,BYR,BZD,CAD,CDF,CHF,CLP,CNH,CNY,COP,CRC,CUC,CUP,CVE,CYP,CZK,DEM,DJF,DKK,DOP,DZD,EEK,EGP,ERN,ESP,ETB,EUR,FIM,FJD,FKP,FRF,GBP,GEL,GGP,GHC,GHS,GIP,GMD,GNF,GRD,GTQ,GYD,HKD,HNL,HRK,HTG,HUF,IDR,IEP,ILS,IMP,INR,IQD,IRR,ISK,ITL,JEP,JMD,JOD,JPY,KES,KGS,KHR,KMF,KPW,KRW,KWD,KYD,KZT,LAK,LBP,LKR,LRD,LSL,LTL,LUF,LVL,LYD,MAD,MDL,MGA,MGF,MKD,MMK,MNT,MOP,MRO,MRU,MTL,MUR,MVR,MWK,MXN,MYR,MZM,MZN,NAD,NGN,NIO,NLG,NOK,NPR,NZD,OMR,PAB,PEN,PGK,php,PKR,PLN,PTE,PYG,QAR,ROL,RON,RSD,RUB,RWF,SAR,SBD,SCR,SDD,SDG,SEK,SGD,SHP,SIT,SKK,SLL,SOS,SPL,SRD,SRG,STD,STN,SVC,SYP,SZL,THB,TJS,TMM,TMT,TND,TOP,TRL,TRY,TTD,TVD,TWD,TZS,UAH,UGX,USD,UYU,UZS,VAL,VEB,VEF,VES,VND,VUV,WST,XAF,XAG,XAU,XBT,XCD,XDR,XOF,XPD,XPF,XPT,YER,ZAR,ZMK,ZMW,ZWD"

  If DateTime.Now > expiration Then
    Dim xhr As Object, re As Object, match As Object
    expiration = DateTime.Now + DateTime.TimeSerial(0, 1, 0) ' + 1 minute '

    Set rates = New Collection

    Set xhr = CreateObject("Msxml2.ServerXMLHTTP.6.0")
    xhr.Open "GET", "https://www.freeforexapi.com/api/live?pairs=USD" & Replace(SYMBOLS, ",", ",USD"), False
    xhr.Send

    Set re = CreateObject("VBScript.RegExp")
    re.Global = True
    re.Pattern = """USD([A-Z]3)"".*?""rate"":([\d.]+)"

    For Each match In re.Execute(xhr.responseText)
        rates.Add Conversion.Val(match.SubMatches.Item(1)), match.SubMatches.Item(0)
    Next
  End If

  ConvCurrency = (Value / rates(fromSymbol)) * rates(toSymbol)
End Function

【讨论】：

请问为什么需要通过时间戳+ 1小时？ 我注意到货币只会在每个工作日的欧洲中部时间 16:00 左右更新。因此可能会导致数据不准确（与其他转换器相比）。 @kenrick tam，+ 1 hour 表示缓存速率的生命周期。它将每小时最多请求一次服务。我添加了另一个示例来获取中端市场实时价格。【参考方案2】：

tl;博士

    您当前的构造产生的权限被拒绝。该端点可能不适合公共访问。此外，查看页面实际检索信息的方式，该设置看起来肯定是为了防止抓取 您还希望变量和子函数/函数的标题更具描述性 如果执行大量操作，您不想使用每次都创建 xmlhttp/IE 对象的函数。您想将 xmlhttp/IE 对象作为参数传递给函数，或者在 sub 期间在循环中使用它。

我的建议如下：

    尽可能使用 API。查看可用的不同 API。 @PatrickHonerez 指的是 https://www.alphavantage.co/，这很有用。我参考了那个网站here。链接中的代码是关于如何设置一个类来保存发出大量请求的 xmlhttp 对象的想法。 假设不违反服务条款和条件：如果请求数量是 API 调用的一个问题（您真的需要每天超过 500 个请求吗？它们是否支持批量转换？）那么您可以查看自动化 IE 并使用子循环运行所有请求。 This 向您展示了从工作表中读取值（在您的情况下为 From 和 To ）并传递给 .Navigate 的基本思想。相反，您将拥有一个二维数组，其中第一列可能是 From，第二列可能是 To。您将在循环中从数组中访问这些值并连接到 

url = "http://www.google.com/search?q=" & myarray(r, 1) & "+to+" & myarray(r, 2)  '< where r is the current counter position in loop

将结果存储在一个数组中，最后一次性写出。基本结构可能如下所示：

Public Sub test()
    Dim ie As InternetExplorer, url As String, inputs(), outputs(), ws As Worksheet, r As Long

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    inputs = ws.Range("A2:B20")                  '< Range containing input values column A with from and column B with to
    ReDim outputs(1 To UBound(inputs, 1))        'size output array to number of rows read in from sheet
    Set ie = New InternetExplorer
    With ie
        .Visible = True
        For r = LBound(inputs, 1) To UBound(inputs, 1)
            url = "http://www.google.com/search?q=" & from_currency & "+to+" & to_currency '"HKD", "USD"
            .Navigate2 url
            While .Busy Or .readyState <> 4: DoEvents: Wend
            outputs(r) = .document.querySelector("#knowledge-currency__tgt-input").innerText
        Next
    End With
    'Depending on size of outputs you may need to loop to write out instead of transpose
    ws.Cells(2, 3).Resize(UBound(outputs), 1) = Application.Transpose(outputs)
End Sub

您需要进行错误处理，并考虑如何处理可能被阻止、失去互联网连接、页面加载失败、输入错误.....

    探索该页面的实际 Web 流量，看看您是否可以模仿该页面实际执行的请求。与选项 2 一样，您需要查看条款和条件对此有何规定。从长远来看，这也可能是一种更脆弱的方法。

【讨论】：

【参考方案3】：

这是我根据 QHarr 的回答制作的函数：

Option Explicit

Function OnlineCurrency(current_country As String, to_country As String) As String
Dim ie As InternetExplorer
Dim url As String

Set ie = New InternetExplorer
With ie
    .Visible = False
    url = "http://www.google.com/search?q=" & current_country & "+to+" & to_country
    .Navigate2 url
    While .Busy Or .readyState <> 4: DoEvents: Wend
    OnlineCurrency = .document.querySelector(".dDoNo").innerText
    OnlineCurrency = Left(OnlineCurrency, InStr(OnlineCurrency, " ") - 1)
    .Quit
End With

End Function

但还是有一些限制：

1) 当函数需要运行多次时，excel可能会崩溃（由于内存使用率高）

2) 有时结果会反馈VALUE#（这可能是由于同时对谷歌页面的大量查询）

3) 如果 Google 因更新而更改其类名，则程序本身将毫无用处。

【讨论】：

以上是关于VBA获取在线货币的主要内容，如果未能解决你的问题，请参考以下文章

Access + VBA：货币变化。区域设置

Excel + VBA 与货币格式之间的精度问题

通过 Excel VBA 通过 Outlook 发送电子邮件 - 将字符串转换为货币格式或百分比

通过数字货币赚取被动收入

如何在 Paypal 电子商务网站中处理多种货币？

NSNumberFormatter - 获取货币代码的货币符号