Getting currency exchange rate from Alpha Vantage API

[Worf99]

Hi,
I need to get real time currency exchange rate EUR/USD.

I must use this<code style="margin: 0px; padding: 1px 5px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; background-color: rgb(239, 240, 241);">https://www.alphavantage.co/query?function=CURRENCY_EXCHANGE_RATE&from_currency=EUR&to_currency=USD&apikey=xxxxxxxxxx</code>

in the browser it returns this

{
"Realtime Currency Exchange Rate": {
"1. From_Currency Code": "EUR",
"2. From_Currency Name": "Euro",
"3. To_Currency Code": "USD",
"4. To_Currency Name": "United States Dollar",
"5. Exchange Rate": "1.15247200",
"6. Last Refreshed": "2018-10-06 17:13:29",
"7. Time Zone": "UTC"
}
}

How can I assign the value of "5. Exchange Rate" to a variable in VBA?

Thank you very much.

 

[Worf99]

Renaming to Sheet1 gives now another error.
Run-time error 429
The ActiveX component is not able to create the object.

Going to debug it highlights this:
Set script = CreateObject("MSScriptControl.ScriptControl")

 

[lrobbo314]

Try changing that line of code to
Set script = CreateObject("ScriptControl")

 

[Worf99]

Still the same error. To be sure, I edited, saved, closed, reopened the file.
Same error.

 

[Worf99]

Do you think I may have to add some new Reference in the VBE?

 

[lrobbo314]

That error seems to pop up if you are using a 64bit version of Office. If the change from the post above doesn't work, you can try the code below.

Public Sub Extract_JSON_Data2()




    Dim script As Object
    Dim HTTPobj As Object
    Dim URL As String
    Dim JSONobj As Object
    Dim SMAlist As Object
    Dim KeysObj As Object
    Dim Keys As Variant, Key As Variant
    Dim dateItem As Object
    Dim destCell As Range, r As Long
    Dim Tmp As Object
    
    
    With Worksheets("Sheet1")
        .Cells.ClearContents
        .Range("A1:B1").Value = Array("Description", "Value")
        Set destCell = .Range("A2")
    End With
    
    Set script = CreateObjectx86("MSScriptControl.ScriptControl")
    script.Language = "JScript"
    script.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; }"
    script.AddCode "function getItemByKey(jsonObj, key) { return jsonObj[key]; }"
    
    URL = "https://www.alphavantage.co/query?function=CURRENCY_EXCHANGE_RATE&from_currency=EUR&to_currency=USD&apikey=ES1RXJ7VF1C1L9N5"
    
    Set JSONobj = Nothing
    Set HTTPobj = CreateObject("MSXML2.XMLHTTP")
    With HTTPobj
        .Open "GET", URL, False
        .Send
        If .Status = 200 Then
            Set JSONobj = script.Eval("(" & .responseText & ")")
        End If
    End With
    
    If Not JSONobj Is Nothing Then
        Set SMAlist = VBA.CallByName(JSONobj, "Realtime Currency Exchange Rate", VbGet)
        Set KeysObj = script.Run("getKeys", SMAlist)
        r = 0
        For Each Key In KeysObj
            destCell.Offset(r, 0).Value = Key
            destCell.Offset(r, 1).Value = VBA.CallByName(SMAlist, Key, VbGet)
            r = r + 1
        Next
    End If
        
    CreateObjectx86 , True ' close mshta host window at the end
End Sub


Function CreateObjectx86(Optional sProgID, Optional bClose = False)


    Static oWnd As Object
    Dim bRunning As Boolean


    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
        bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
        If bClose Then
            If bRunning Then oWnd.Close
            Exit Function
        End If
        If Not bRunning Then
            Set oWnd = CreateWindow()
            oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
        End If
        Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Set CreateObjectx86 = CreateObject(sProgID)
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If


End Function


Function CreateWindow()


    ' source [url]http://forum.script-coding.com/viewtopic.php?pid=75356#p75356[/url]
    Dim sSignature, oShellWnd, oProc


    On Error Resume Next
    sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head>********>moveTo(-32000,-32000);document.title='x86Host'*********><hta:application showintaskbar=no />******** id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object>********>shell.putproperty('" & sSignature & "',document.parentWindow);*********></head>""", 0, False
    Do
        For Each oShellWnd In CreateObject("Shell.Application").Windows
            Set CreateWindow = oShellWnd.GetProperty(sSignature)
            If Err.Number = 0 Then Exit Function
            Err.Clear
        Next
    Loop


End Function

 

[Worf99]

Hi,
I tried the new code.

I have a syntax error here on the second row

CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:********>moveTo(-32000,-32000);document.title='x86Host'*********><hta:application showintaskbar="no">******** id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'>********>shell.putproperty('" & sSignature & "',document.parentWindow);*********>

""", 0, False</hta:application>

 

[lrobbo314]

What version of Windows and Office are you using? 32bit or 64bit?

 

[Worf99]

Windows 10 64 bit and Office 64 bit.

It seems to me that this code " """, 0, False " is like not linked to the previous code.

 

[lrobbo314]

Oh, the website is doing something weird when I paste the code. It is converting it to garbage when i post it. So, for the code below, you are going to have to go through and change every "!" to a "<", and every "@" to a ">".

CreateObject("WScript.Shell").Run """, 0, False"%systemroot%\syswow64\mshta.exe about:""about:!head@!script@moveTo(-32000,-32000);document.title='x86Host'!/script@!hta:application showintaskbar=no /@!object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'@!param name=RegisterAsBrowser value=1@!/object@!script@shell.putproperty('" & sSignature & "',document.parentWindow);!/script@!/head@""", 0, False

 

[John_w]

Since the JSON data structure is very simple, you could extract the exchange rate without a JSON parser, like this:

Public Sub Extract_Exchange_Rate()

    Dim objHTTP As Object
    Dim URL As String
    Dim p1 As Long, p2 As Long
    Dim exchangeRate As String
        
    Const APIkey As String = "your API key here"
    
    URL = "https://www.alphavantage.co/query?function=CURRENCY_EXCHANGE_RATE&from_currency=EUR&to_currency=USD&apikey=" & APIkey
    
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    With objHTTP
        .Open "GET", URL, False
        .Send
        If .Status = 200 Then
            p1 = InStr(.responsetext, "5. Exchange Rate")
            If p1 > 0 Then
                p2 = InStr(p1, .responsetext, ": ")
                p1 = InStr(p2 + 2, .responsetext, """")
                p2 = InStr(p1 + 1, .responsetext, """")
                exchangeRate = Mid(.responsetext, p1 + 1, p2 - p1 - 1)
                MsgBox "Exchange Rate = " & exchangeRate
            Else
                MsgBox .responsetext
            End If
        Else
            MsgBox URL & vbCrLf & "returned error " & .StatusText
        End If
    End With
        
End Sub