获取汇率 - 帮助我更新曾经可用的 Excel VBA 代码中的 URL [英] Get exchange rates - help me update URL in Excel VBA code that used to work
问题描述
我正在使用这个有效的 VBA 代码，现在该函数返回 0，因为 URL 已更改.我现在应该使用哪个网址?
非常感谢.
函数 YahooCurrencyConverter(ByVal strFromCurrency, ByVal strToCurrency, Optional ByVal strResultType = "Value")出错时转到 ErrorHandler'在里面Dim strURL As StringDim objXMLHttp 作为对象Dim strRes As String, dblRes As DoubleSet objXMLHttp = CreateObject("MSXML2.ServerXMLHTTP")strURL = "http://finance.yahoo.com/d/quotes.csv?e=.csv&f=c4l1&s=" &strFromCurrency &strToCurrency &"=X"'发送 XML 请求使用 objXMLHttp.打开GET"，strURL，假.setRequestHeader "Content-Type", "application/x-www-form-URLEncoded".发送strRes = .ResponseText结束于'解析响应dblRes = Val(Split(strRes, ",")(1))选择案例 strResultType案例价值":YahooCurrencyConverter = dblRes其他情况:YahooCurrencyConverter = "1 " &strFromCurrency &" = " &dblRes &" " &货币对结束选择清洁出口:设置 objXMLHttp = 无退出函数错误处理程序:雅虎货币转换器 = 0转到清洁退出结束函数拆分:
现在您已经获得了可以使用 Split 函数解析的 JSON 字符串.在这里，我正在阅读来自单元格的评论中的 JSON
选项显式公共子 GetExchangeRate()Dim json 作为字符串json = [A1]Debug.Print Split(Split(json, """5. Exchange Rate"": ")(1), ",")(0)结束子<小时>
JSON 解析器:
这里可以使用 JSON 解析器，
初始对象是一个包含另一个字典的字典.字典由 {} 表示.您使用键Realtime Currency Exchange Rate 访问第一个字典，然后通过关联键5 从内部字典访问所需的值.汇率
使用 JSON 解析器的整个请求:
选项显式公共子 GetRate2()Dim URL As String, json As String, http As ObjectURL = "https://www.alphavantage.co/query?function=CURRENCY_EXCHANGE_RATE&from_currency=EUR&to_currency=USD&apikey=yourAPIkey"设置 http = CreateObject("MSXML2.XMLHTTP")使用 http.打开GET"，网址，假.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT".发送json = .responseText结束于Debug.Print JsonConverter.ParseJson(json)("实时货币汇率")("5.汇率")结束子<小时>
作为 UDF:
选项显式公共子测试()Debug.Print CurrencyConverter("EUR", "USD")结束子公共函数 CurrencyConverter(ByVal FromCurrency, ByVal ToCurrency) As StringDim URL As String, json As String, http As ObjectURL = "https://www.alphavantage.co/query?function=CURRENCY_EXCHANGE_RATE&from_currency=" &FromCurrency &"&to_currency=" &ToCurrency &&apikey=你的APIkey"设置 http = CreateObject("MSXML2.XMLHTTP")使用 http.打开GET"，URL，假.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT".发送json = .responseText结束于CurrencyConverter = JsonConverter.ParseJson(json)("实时货币汇率")("5.汇率")'CurrencyConverter = Replace$(JsonConverter.ParseJson(json)("实时货币汇率")("5.汇率"), Application.DecimalSeparator, ".")结束函数使用拆分函数替换倒数第二个函数行
CurrencyConverter = Replace$(Split(Split(json, """5. Exchange Rate"": ")(1), ",")(0), Chr$(34), vbNullString)I was using this VBA code that was working, now the function returns 0 because the URL has changed. What URL should I use now?
Thank you very much.
Function YahooCurrencyConverter(ByVal strFromCurrency, ByVal strToCurrency, Optional ByVal strResultType = "Value")
On Error GoTo ErrorHandler
'Init
Dim strURL As String
Dim objXMLHttp As Object
Dim strRes As String, dblRes As Double
Set objXMLHttp = CreateObject("MSXML2.ServerXMLHTTP")
strURL = "http://finance.yahoo.com/d/quotes.csv?e=.csv&f=c4l1&s=" & strFromCurrency & strToCurrency & "=X"
'Send XML request
With objXMLHttp
.Open "GET", strURL, False
.setRequestHeader "Content-Type", "application/x-www-form-URLEncoded"
.Send
strRes = .ResponseText
End With
'Parse response
dblRes = Val(Split(strRes, ",")(1))
Select Case strResultType
Case "Value": YahooCurrencyConverter = dblRes
Case Else: YahooCurrencyConverter = "1 " & strFromCurrency & " = " & dblRes & " " & strToCurrency
End Select
CleanExit:
Set objXMLHttp = Nothing
Exit Function
ErrorHandler:
YahooCurrencyConverter = 0
GoTo CleanExit
End Function
Split:
Now you have obtained the JSON string you can parse with Split function. Here I am reading the JSON in the comments from a cell
Option Explicit
Public Sub GetExchangeRate()
Dim json As String
json = [A1]
Debug.Print Split(Split(json, """5. Exchange Rate"": ")(1), ",")(0)
End Sub
JSON Parser:
Here you can use a JSON parser, JSONConverter.bas and then add a reference via VBE > Tools > References > Microsoft Scripting Dictionary
Public Sub GetRate()
Dim jsonStr As String, json As Object
jsonStr = [A1]
Debug.Print JsonConverter.ParseJson(jsonStr)("Realtime Currency Exchange Rate")("5. Exchange Rate")
End Sub
This is the path to your desired change rate:
The initial object is a dictionary containing another dictionary. Dictionaries are denoted by {}. You access the first dictionary with the key Realtime Currency Exchange Rate and then the required value, from the inner dictionary, by the associated key: 5. Exchange Rate
Whole request with JSON parser:
Option Explicit
Public Sub GetRate2()
Dim URL As String, json As String, http As Object
URL = "https://www.alphavantage.co/query?function=CURRENCY_EXCHANGE_RATE&from_currency=EUR&to_currency=USD&apikey=yourAPIkey"
Set http = CreateObject("MSXML2.XMLHTTP")
With http
.Open "GET", URL, False
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
json = .responseText
End With
Debug.Print JsonConverter.ParseJson(json)("Realtime Currency Exchange Rate")("5. Exchange Rate")
End Sub
As an UDF:
Option Explicit
Public Sub Test()
Debug.Print CurrencyConverter("EUR", "USD")
End Sub
Public Function CurrencyConverter(ByVal FromCurrency, ByVal ToCurrency) As String
Dim URL As String, json As String, http As Object
URL = "https://www.alphavantage.co/query?function=CURRENCY_EXCHANGE_RATE&from_currency=" & FromCurrency & "&to_currency=" & ToCurrency & "&apikey=yourAPIkey"
Set http = CreateObject("MSXML2.XMLHTTP")
With http
.Open "GET", URL, False
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
json = .responseText
End With
CurrencyConverter = JsonConverter.ParseJson(json)("Realtime Currency Exchange Rate")("5. Exchange Rate")
'CurrencyConverter = Replace$(JsonConverter.ParseJson(json)("Realtime Currency Exchange Rate")("5. Exchange Rate"), Application.DecimalSeparator, ".")
End Function
To use split function replace penultimate function line with
CurrencyConverter = Replace$(Split(Split(json, """5. Exchange Rate"": ")(1), ",")(0), Chr$(34), vbNullString)
这篇关于获取汇率 - 帮助我更新曾经可用的 Excel VBA 代码中的 URL的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
