VBA obtain online currency

Question

Recently I just realized the yahoo finance (.csv) had been shut down, and leading I cannot do the online currency (update) in my excel. Hence I tried to use the below method to do my work.

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

2) As I had noticed that the currency rate will be shown in the div class="dDoNo vk_bk"

Below is the work I am trying to do.

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

But seems I cannot show anything about that. Can someone help me / point out the problems for me? Thanks

Answer 1

There are many services around offering the currency rates for free.

If your goal is to get/convert the rates with an UDF, then consider caching the rates to avoid being kicked off by the service due to too many requests.

Here's an UDF using caching to efficiently convert a currency with the rates from the European Central Bank (daily updated):

''
' 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

If you prefer the mid-market live rates, this example takes the rates from 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;dr

1. Your current construct yields permission denied. That endpoint is likely not intended for public access. Also, looking at what the page actually does to retrieve info, the set-up definitely looks like it is intended to prevent scraping
2. You also want more descriptive titles for variables and subs/functions
3. If performing for large numbers you don't want to use a function which creates an xmlhttp/IE object each time. You want to pass the xmlhttp/IE object as an argument to a function or work with it in a loop during a sub.

My recommendations would be as follows:

1. Use an API where possible. Have a look at the different APIs available. @PatrickHonerez refers to https://www.alphavantage.co/ which is useful. I make reference to that site here. The code at the link is an idea of how you could go about setting up a class to hold your xmlhttp object where issuing large numbers of requests.
2. Assuming not against T&Cs of service: If number of requests is an issue for API call (do you really need more than 500 requests per day? Do they support bulk conversions?) then you can look at automating IE and use a sub to run for all requests in a loop. This shows you the basic idea of reading values from sheet (in your case From and To ) and passing to .Navigate. You would instead have a 2D array where first column might be From and second column To. You would access those values from the array in a loop and concatenate into

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

Store results in an array and write out in one go at end. A basic structure might look like:

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

You'd need error handling though and consider what to do about potentially being blocked, losing internet connection, page load fails, incorrect inputs.....

3. Explore the actual web traffic for that page and see if you can mimic the request the page actually does. As with option 2 you will need to see what the terms and conditions have to say about doing this. This is also likely a more fragile method in the long run.