VBA获取在线货币

Question

最近我才意识到雅虎金融（.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

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

Answer 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

Answer 2

tl;博士

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

我的建议如下：

1. 尽可能使用 API。查看可用的不同 API。 @PatrickHonerez 指的是 https://www.alphavantage.co/，这很有用。我参考了那个网站here。链接中的代码是关于如何设置一个类来保存发出大量请求的 xmlhttp 对象的想法。
2. 假设不违反服务条款和条件：如果请求数量是 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

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

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

Answer 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 因更新而更改其类名，则程序本身将毫无用处。