Related
I'm very new to API coding but I have created an API Code that inputs pressure and outputs temperature for a specific refrigerant on a website. However, I can only call for one refrigerant at a time, I was wondering if it is possible to create a string with all the refrigerant id (refId) numbers, so the API code could run through all of them in one long run?
Option Explicit
Public Function GetPressureFromTemp(ByVal Temperature As Double) As Double
Dim body As String
body = "{""Temperature"":""" & Temperature & """,""refId"":""r13"",""temperatureUnit"":""fahrenheit"",""pressureUnit"":""psi"","
body = body & """pressureReferencePoint"":""gauge"","
body = body & """pressureCalculationPoint"":""bubble"",""gaugeType"":""dry"",""altitudeInMeter"":0}"
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", "https://reftools.danfoss.com/api/ref-slider/Pressure?refId=r13", False
.setRequestHeader "content-type", "application/json; charset=utf-8"
.send body
GetPressureFromTemp = CDbl(.responseText)
End With
End Function
Public Sub test()
Dim n As Double
Dim a As Double
a = 4984
n = -150.8
Do Until n >= 74.93
n = n + 0.1
'Debug.Print GetPressureFromTemp(n)
Range("J" & a) = GetPressureFromTemp(n)
a = a + 1
Loop
End Sub
I'm not sure how to loop through each ref ID, however I have the whole list containing the refrigerant id
I've been successfully using the Yahoo Finance API cookie/crumb technique to get historical stock quotes for many years. On April 28th, 2022, it broke, and excessive exercise of vocabulary has failed to fix it.
The technique is to lookup an illegible stock symbol, because part of the returned cookie can be used to obtain real historical data on successive uses of the historical Yahoo API. I've tried it with illegible and legitimate stock symbols. I'm using Excel 2019 VBA, and the debug seems to hang on the ".waitForResponse (10)" instruction. It's part of a loop, and it hangs on the first instance. The code is shown below. It successfully writes a zero on ws1.S10, but it fails to do anything after the "Next cook" instruction. Did Yahoo intentionally break the Finance API again, or did Microsoft "improve" Excel? Or, more likely, did I do something stump stupid, like turn on the computer? Thanks!
Sub HistUp()
Dim resultFromYahoo, csv_rows() As String
Dim objRequest
Dim resultArray As Variant
Dim eagle, nColumns, cook, iRows, iCols As Integer
Dim CSV_Fields As Variant
Dim ticker, tickerURL, cookie, crumb As String
Dim HistQuote, HistDiv, DefaultKey As String
Dim Curr, StartPer As String
Dim fox, sheep, bear, elk, wolf, raccoon, snake As Integer
Dim julian, ricky, bubbles As Double
Dim crumbStartPos, crumbEndPos, Lastrow1, Lastrow2 As Long
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets(1)
Set ws2 = wb.Worksheets(2)
Set ws3 = wb.Worksheets(3)
Set ws4 = wb.Worksheets(4)
Set ws5 = wb.Worksheets(5)
Application.EnableEvents = False
Application.DisplayAlerts = False
eagle = ActiveSheet.Index
wb.Worksheets("Warn").Select
wb.Worksheets("Warn").Range("A1").Select
DoEvents
'getCookieCrumb
For cook = 0 To 5 'ask for a valid crumb 6 times
ws1.Range("S10") = cook
Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
With objRequest
.Open "GET", "https://finance.yahoo.com/lookup?s=turpitude", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.send
.waitForResponse (10)
cookie = Split(.getResponseHeader("Set-Cookie"), ";")(0)
crumbStartPos = InStrRev(.ResponseText, """crumb"":""") + 9
crumbEndPos = crumbStartPos + 11
crumb = Mid(.ResponseText, crumbStartPos, crumbEndPos - crumbStartPos)
End With
If Len(crumb) = 11 Then 'a valid crumb is 11 characters long
Exit For
End If
Next cook
I have the same problem. Looks like Yahoo changed the Yahoo finance API.
When I comment out the line:
cookie = Split(.getResponseHeader("Set-Cookie"), ";")(0)
the code seems to work as before.
Then also comment out
'.setRequestHeader "Cookie", Cookie
when you send the request. Rest of my code:
'CONSTRUCT THE URL:
'interval=1d or 1wk or 1mo, events=dividends or events=history (prices) or events=splits
WebRequestURL = "https://query1.finance.yahoo.com/v7/finance/download/" & StockSymbol & _
"?period1=" & UnixStartDate & "&period2=" & UnixEndDate & _
"&interval=" & UrlInterval & "&events=" & UrlEvents & "&crumb=" & Crumb
'FETCH THE DATA:
With WebRequest
.Open "GET", WebRequestURL, False
'.setRequestHeader "Cookie", Cookie
.Send
.waitForResponse (10)
End With
As people have commented, the "Set-Cookie" header is no longer in the response, however the crumbstore is still there, so I would recommend checking to see if the header exists, and if not continue without setting that header or including the crumb.
Here is more robust code that allows you to select if you want price history, dividends, or split. You can also select a date range, by converting the dates to POSIX. It can also accommodate a proxy server. Feel free to comment on any improvements I can make to this code.
'New Yahoo Data Method
'sEvent: history, div, split
'sInterval: 1d,1wk,1mo
Public Function GetNewYahooData(sSymbol As String, sStart As String, sEnd As String, sEvent As String, sInterval As String, sProxy As String) As String
On Error GoTo Error_Message
Const sTestURL = "https://query1.finance.yahoo.com/v7/finance/download/"
Const sBaseURL = "https://finance.yahoo.com/quote/^GSPC"
'This assumes the crumb appears like this: "CrumbStore":{"crumb":"taEvjA8DFqs"}
Const sCrumbStart = """CrumbStore"":{""crumb"":"""
Const sCrumbEnd = """"
Const sTickerReplace = "TTTT"
Const sPeriod1Replace = "pppppppp"
Const sPeriod2Replace = "qqqqqqqq"
Const sEventReplace = "eeeeeeee"
Const sCrumbReplace = "cccccccc"
Const sIntervalReplace = "iiiiiiii"
Dim sReturn As String
Dim sTemURL As String
Dim sCookie As String
Dim sCrumb As String
Dim dtStart As Date
Dim dtEnd As Date
Dim lngCrumbStart As Long
Dim lngCrumbEnd As Long
Dim objRequest As WinHttp.WinHttpRequest
Dim sContentType As String
Dim bolHaveCrumb As Boolean
dtStart = CDate(sStart)
dtEnd = CDate(sEnd)
bolHaveCrumb = False
'Perform a Yahoo financial lookup on SP500 to get the crumb
Set objRequest = New WinHttp.WinHttpRequest
With objRequest
If Len(sProxy) > 0 Then .SetProxy 2, sProxy, ""
.Open "GET", sBaseURL, False
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.sEnd
.WaitForResponse (10)
sReturn = .ResponseText
If InStr(1, sReturn, sCrumbStart) > 0 Then
lngCrumbStart = InStr(1, sReturn, sCrumbStart) + 23
lngCrumbEnd = InStr(lngCrumbStart, sReturn, sCrumbEnd)
sCrumb = Mid(sReturn, lngCrumbStart, lngCrumbEnd - lngCrumbStart)
sCookie = .GetAllResponseHeaders
If InStr(sCookie, "Set-Cookie") > 0 Then
sCookie = Split(.GetResponseHeader("Set-Cookie"), ";")(0)
bolHaveCrumb = True
Else
bolHaveCrumb = False
End If
End If
End With
'This is currently https://query1.finance.yahoo.com/v7/finance/download/TTTT?period1=pppppppp&period2=qqqqqqqq&interval=iiiiiiii&events=eeeeeeee&crumb=cccccccc
sTemURL = gYAHOO_HIS_URL
sTemURL = Replace(sTemURL, sIntervalReplace, sInterval)
sTemURL = Replace(sTemURL, sTickerReplace, sSymbol)
sTemURL = Replace(sTemURL, sPeriod1Replace, toPOSIX(dtStart))
sTemURL = Replace(sTemURL, sPeriod2Replace, toPOSIX(dtEnd))
sTemURL = Replace(sTemURL, sEventReplace, sEvent)
If bolHaveCrumb Then
sTemURL = Replace(sTemURL, sCrumbReplace, sCrumb)
Else
sTemURL = Replace(sTemURL, "&" & sCrumbReplace, "")
End If
Set objRequest = New WinHttp.WinHttpRequest
With objRequest
If Len(sProxy) > 0 Then .SetProxy 2, sProxy, ""
.Open "GET", sTemURL, False
If bolHaveCrumb Then .SetRequestHeader "Cookie", sCookie
.sEnd
.WaitForResponse (10)
sContentType = .GetResponseHeader("Content-Type")
sReturn = StrConv(.ResponseText, vbUnicode)
sReturn = StrConv(sReturn, vbFromUnicode)
End With
If Len(sReturn) > 0 Then
GetNewYahooData = sReturn
Else
GetNewYahooData = ""
End If
Exit Function
Error_Message:
MsgBox err.Description, vbCritical, "Yahoo Price Retrieval"
GetNewYahooData = ""
End Function
'Helper function to convert a date into its POSIX representation
Public Function toPOSIX(dt As Date) As Long
On Error GoTo err
toPOSIX = DateDiff("s", "1/1/1970", dt)
Exit Function
err:
MsgBox err.Description, vbOKOnly, "toPOSIX"
End Function
Also sometimes the first time you make the request, it might not return anything, so I usually try 5 times before giving up.
'Sometimes we won't get a response on the first try, so try 5 times
While Not YahooEnd
gHTMLFileHis = GetNewYahooData(txtSymbol.Text, txtStartDate.Text, txtEndDate.Text, sEvent, sInterval, txtproxy.Text)
i = i + 1
If Len(gHTMLFileHis) = 0 Then
YahooSuccess = False
Else
arrRows = Split(gHTMLFileHis, vbLf)
arrRow = Split(arrRows(0), ",")
If arrRow(0) = StrConv("Date", vbUnicode) Or arrRow(0) = "Date" Then
YahooSuccess = True
YahooEnd = True
End If
If i = 5 Then YahooEnd = True
End If
Wend
So I have some json formatted data, in which an article name (the field in my case is "description courte") can be used multiple times and have a different price each time, I want to get those prices and display them in a listbox and let the user pick which one to parse in the column "price" which is found.offset(0,3). Note that I only search for fields that exist in the Range("G:G") This is what I did so far :
This code is returning an error : index does not belong in the selection (sorry if translated badly) at the
Set Found = Range("G:G").Find(ArtDict.Items()(Index).Name)
Code example
Sub prix()
Dim http As New WinHttpRequest
Dim resp As String
Dim url As String
url = "https://api.airtable.com/v0/appY6Wo3AmLHqHkjr/Materiaux?api_key=key_here" & Fields
http.Open "GET", url, False
http.Send
Dim JSON As Object
Dim Found As Range
Dim ArtDict As New Dictionary, Article As class_Article
Dim Index As Long, count As Long
Set JSON = JsonConverter.ParseJson(http.ResponseText)
For Index = 1 To JSON("records").count
Set Found = Range("G:G").Find(ArtDict.Items()(Index).Name)
If Not ArtDict.Exists(JSON("records")(Index)("fields")("description courte")) Then
'If this article doesn't exist in the article dictionary, then create the article object and add it to the dictionary
Set Article = New class_Article
Article.Name = JSON("records")(Index)("fields")("description courte")
Article.ParsePrice JSON("records")(Index)("fields")("prix unitaire HT")
Debug.Print Article.Name, Article.HighPrice, Article.LowPrice
ArtDict.Add Article.Name, Article
Else
Set Article = ArtDict(JSON("records")(Index)("fields")("description courte"))
Article.ParsePrice JSON("records")(Index)("fields")("prix unitaire HT")
Debug.Print Article.Name, Article.HighPrice, Article.LowPrice
Set ArtDict(JSON("records")(Index)("fields")("description courte")) = Article
End If
If Not Found Is Nothing Then
count = Found.Offset(0, 4).Value + 1
If count > 1 Then
UserForm1.Show
UserForm1.ListBox1.AddItem (Article.HighPrice)
UserForm1.ListBox1.AddItem (Article.LowPrice)
Found.Offset(0, 3) = UserForm1.ListBox1.Value
End If
End If
Next Index
End Sub
JSON SAMPLE
{
"records": [
{
"id": "rec0MS66BnYY0vK32",
"fields": {
"id": 124,
"article": "osmo 24m2 3062MAT 0.75L",
"categorie": [
"recvw95DBiWvk3zaH"
],
"udv": 1,
"unité": [
"recYQ9wpLDgNDk5BW"
],
"prix HT de l'udv": 29.09,
"date d'achat": "2019-08-01",
"distributeur": "cotet mtp",
"reference distributeur": "OSMO-ORI-0.75-M",
"id facture": "FA19036300",
"created on": "2020-02-07",
"by": "remyvignaux",
"description courte": "osmo 3062MAT",
"prix unitaire HT": 29.09
},
"createdTime": "2021-02-28T20:53:00.000Z"
},....etc
CLASS_ARTICLE
Option Explicit
Public Name As String
Public HighPrice As Currency
Public LowPrice As Currency
Private Sub Class_Initialize()
HighPrice = -922337203685477.5807# 'Set value to lowest possible value
LowPrice = 922337203685477.5807# 'Set value to the highest possible value
End Sub
Public Function ParsePrice(ByVal NewPrice As Currency) As Boolean
HighPrice = IIf(NewPrice > HighPrice, NewPrice, HighPrice)
LowPrice = IIf(NewPrice < LowPrice, NewPrice, LowPrice)
End Function
Parse the JSON into a collection of articles (using a dictionary) and then process each article in turn. The price selection can be an article method. I used an input box just to show the principle but you could use listbox. The results are shown on Sheet1.
Option Explicit
Sub prix()
' get json into a string
Dim fso, ts, s
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile("c:\temp\json.txt")
s = ts.ReadAll
ts.Close
Dim dictArt As New Dictionary, oArt As Class_Article ' holds articles
Dim name As String, price As Currency
Dim JSON As Object, rec, fld
Set JSON = JsonConverter.ParseJson(s)
' parse json
For Each rec In JSON("records")
Set fld = rec("fields")
name = fld("description courte")
price = fld("prix unitaire HT")
If dictArt.Exists(name) Then
dictArt(name).AddPrice price
Else
Set oArt = New Class_Article
oArt.name = name
oArt.AddPrice price
dictArt.Add name, oArt
End If
Next
' result to sheet1
Dim key, i As Long: i = 1
Sheet1.Cells.Clear
Sheet1.Range("A1:C1") = Array("Description", "Price Count", "Price")
For Each key In dictArt
i = i + 1
Set oArt = dictArt(key)
Sheet1.Cells(i, 1) = oArt.Name
Sheet1.Cells(i, 2) = oArt.PriceCount
' if more than once give options
If oArt.PriceCount > 1 Then
Sheet1.Cells(i, 1).Select
Sheet1.Cells(i, 3).Interior.Color = vbYellow
oArt.SelectPrice
If oArt.bSelected Then
Sheet1.Cells(i, 3) = oArt.price
Sheet1.Cells(i, 3).Interior.Color = xlNone
End If
Else
Sheet1.Cells(i, 3) = oArt.price
End If
Next
End Sub
' Class_Article
Public name As String
Public price As Currency
Public PriceCount As Integer
Public bSelected As Boolean
Private prices As New Collection
Private i As Integer
Public Sub AddPrice(ByVal price As Currency)
PriceCount = PriceCount + 1
Me.price = price
prices.Add price, CStr(PriceCount)
End Sub
Sub SelectPrice()
Dim msg As String
bSelected = False
' build option list
msg = name & " has " & PriceCount & " prices"
For i = 1 To PriceCount
msg = msg & vbCr & "(" & i & ") " & prices(i)
Next
' user selects
begin:
i = Application.InputBox(msg, "Select Price 1 to " & PriceCount, 1, Type:=1) ' int
If i < 1 Then
Exit Sub
ElseIf i > PriceCount Then
GoTo begin
End If
' selected price
price = prices(i)
bSelected = True
End Sub
I am trying to get data in many currencies, and convert all of them to Euro.
I found a code on this website, but the code is too advanced for me and is impossible to debug with my knowledge.
I isolated the error, it is when the code reaches xhr.send. Do you have any idea why this would happen?
I do not understand what this part is doing, therefore it is difficult for me to debug it.
The error message that I get is as follow :
Run-time error '-2147012889 (80072ee7)' Automation error
Sub test()
Dim test1 As Variant
test1 = ConvCurrency(1, "USD", "GBP")
MsgBox (test1)
End Sub
''
' 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
EDIT : for any future reader, I Changed my object to msxml2.xmlhttp, now it is working.
It looks OK as I browse it, apart from the object, that I think should use:
CreateObject("MSXML2.ServerXMLHTTP")
You may check out similar code in my project VBA.CurrencyExchange which can retrieve rates from 10 sources. Too much code to post here, but the base function for the ECB is:
' Retrieve the current exchange rates from the European Central Bank, ECB,
' for Euro having each of the listed currencies as the base currency.
' The rates are returned as an array and cached until the next update.
' The rates are updated once a day at about UTC 15:00.
'
' Source:
' http://www.ecb.europa.eu/stats/policy_and_exchange_rates/euro_reference_exchange_rates/html/index.en.html
'
' Note:
' The exchange rates on the European Central Bank's website are indicative rates
' that are not intended to be used in any market transaction.
' The rates are intended for information purposes only.
'
' Example:
' Dim Rates As Variant
' Rates = ExchangeRatesEcb()
' Rates(7, 0) -> 2018-05-30 ' Publishing date.
' Rates(7, 1) -> "PLN" ' Currency code.
' Rates(7, 2) -> 4.3135 ' Exchange rate.
'
' 2018-06-07. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function ExchangeRatesEcb() As Variant
' Operational constants.
'
' Base URL for European Central Bank exchange rates.
Const ServiceUrl As String = "http://www.ecb.europa.eu/stats/eurofxref/"
' File to look up.
Const Filename As String = "eurofxref-daily.xml"
' Update hour (UTC).
Const UpdateHour As Date = #3:00:00 PM#
' Update interval: 24 hours.
Const UpdatePause As Integer = 24
' Function constants.
'
' Async setting.
Const Async As Variant = False
' XML node and attribute names.
Const RootNodeName As String = "gesmes:Envelope"
Const CubeNodeName As String = "Cube"
Const TimeNodeName As String = "Cube"
Const TimeItemName As String = "time"
Const CodeItemName As String = "currency"
Const RateItemName As String = "rate"
#If EarlyBinding Then
' Microsoft XML, v6.0.
Dim Document As MSXML2.DOMDocument60
Dim XmlHttp As MSXML2.ServerXMLHTTP60
Dim RootNodeList As MSXML2.IXMLDOMNodeList
Dim CubeNodeList As MSXML2.IXMLDOMNodeList
Dim RateNodeList As MSXML2.IXMLDOMNodeList
Dim RootNode As MSXML2.IXMLDOMNode
Dim CubeNode As MSXML2.IXMLDOMNode
Dim TimeNode As MSXML2.IXMLDOMNode
Dim RateNode As MSXML2.IXMLDOMNode
Dim RateAttribute As MSXML2.IXMLDOMAttribute
Set Document = New MSXML2.DOMDocument60
Set XmlHttp = New MSXML2.ServerXMLHTTP60
#Else
Dim Document As Object
Dim XmlHttp As Object
Dim RootNodeList As Object
Dim CubeNodeList As Object
Dim RateNodeList As Object
Dim RootNode As Object
Dim CubeNode As Object
Dim TimeNode As Object
Dim RateNode As Object
Dim RateAttribute As Object
Set Document = CreateObject("MSXML2.DOMDocument")
Set XmlHttp = CreateObject("MSXML2.ServerXMLHTTP")
#End If
Static Rates() As Variant
Static LastCall As Date
Dim Url As String
Dim CurrencyCode As String
Dim Rate As String
Dim ValueDate As Date
Dim ThisCall As Date
Dim Item As Integer
If DateDiff("h", LastCall, UtcNow) < UpdatePause Then
' Return cached rates.
Else
' Retrieve updated rates.
' Define default result array.
' Redim for three dimensions: date, code, rate.
ReDim Rates(0, 0 To 2)
Rates(0, RateDetail.Date) = NoValueDate
Rates(0, RateDetail.Code) = NeutralCode
Rates(0, RateDetail.Rate) = NeutralRate
Url = ServiceUrl & Filename
' Retrieve data.
XmlHttp.Open "GET", Url, Async
XmlHttp.Send
If XmlHttp.Status = HttpStatus.OK Then
' File retrieved successfully.
Document.loadXML XmlHttp.ResponseText
Set RootNodeList = Document.getElementsByTagName(RootNodeName)
' Find root node.
For Each RootNode In RootNodeList
If RootNode.nodeName = RootNodeName Then
Exit For
Else
Set RootNode = Nothing
End If
Next
If Not RootNode Is Nothing Then
If RootNode.hasChildNodes Then
' Find first level Cube node.
Set CubeNodeList = RootNode.childNodes
For Each CubeNode In CubeNodeList
If CubeNode.nodeName = CubeNodeName Then
Exit For
Else
Set CubeNode = Nothing
End If
Next
End If
End If
If Not CubeNode Is Nothing Then
If CubeNode.hasChildNodes Then
' Find second level Cube node.
Set CubeNodeList = CubeNode.childNodes
For Each TimeNode In CubeNodeList
If TimeNode.nodeName = TimeNodeName Then
Exit For
Else
Set TimeNode = Nothing
End If
Next
End If
End If
If Not TimeNode Is Nothing Then
If TimeNode.hasChildNodes Then
' Find value date.
ValueDate = CDate(TimeNode.Attributes.getNamedItem(TimeItemName).nodeValue)
' Find the exchange rates.
Set RateNodeList = TimeNode.childNodes
' Redim for three dimensions: date, code, rate.
ReDim Rates(RateNodeList.Length - 1, 0 To 2)
For Each RateNode In RateNodeList
Rates(Item, RateDetail.Date) = ValueDate
If RateNode.Attributes.Length > 0 Then
' Get the ISO currency code.
Set RateAttribute = RateNode.Attributes.getNamedItem(CodeItemName)
If Not RateAttribute Is Nothing Then
CurrencyCode = RateAttribute.nodeValue
End If
' Get the exchange rate for this currency code.
Set RateAttribute = RateNode.Attributes.getNamedItem(RateItemName)
If Not RateAttribute Is Nothing Then
Rate = RateAttribute.nodeValue
End If
Rates(Item, RateDetail.Code) = CurrencyCode
Rates(Item, RateDetail.Rate) = CDbl(Val(Rate))
End If
Item = Item + 1
Next RateNode
End If
End If
ThisCall = ValueDate + UpdateHour
' Record requested language and publishing time of retrieved rates.
LastCall = ThisCall
End If
End If
ExchangeRatesEcb = Rates
End Function
I haven't checked it in Excel, though, only in Access.
I'm trying to scrap the exchange rates using excel VBA but I can not get the innerText value I need. I don't understand why because the same technique works on the other sites.
URL - https://www.nbs.rs/export/sites/default/internet/english/scripts/kl_srednji.html
Sub GetCurr()
Dim tempHTMLDoc As New MSHTML.HTMLDocument
Dim HTMLCurrency As MSHTML.IHTMLElementCollection
Dim HTMLRows As MSHTML.IHTMLElementCollection
Dim HTMLDate As MSHTML.IHTMLElementCollection
Dim HTMLElem As MSHTML.IHTMLElement
Dim connectionTest As Boolean
Dim EUR, CZK, HRK, HUF, PLN, RON, RSD As String
Dim myURL As String
Dim i As Long
connectionTest = True
myURL = "https://www.nbs.rs/export/sites/default/internet/english/scripts/kl_srednji.html"
Call WebConnection(tempHTMLDoc, connectionTest, myURL)
If connectionTest = False Then Exit Sub
Set HTMLDate = tempHTMLDoc.getElementsByTagName("span")
'Debug.Print HTMLDate.Length
For Each HTMLElem In HTMLDate 'I am looking for which element contains the date (can not find)
Debug.Print HTMLElem.innerText
Next HTMLElem
'I am trying to get the necessary currencies
Set HTMLRows = tempHTMLDoc.getElementsByTagName("tr")
Debug.Print HTMLRows.Length
For i = 0 To HTMLRows.Length - 1 'If lenght > 0
Set HTMLCurrency = HTMLRows(i).getElementsByTagName("td")
If HTMLCurrency.Length > 4 Then 'each currency contains 5 "td" tags
Select Case HTMLCurrency(2).innerText
Case "EUR"
EUR = HTMLCurrency(4).innerText
Case "HRK"
HRK = HTMLCurrency(4).innerText
Case "HUF"
HUF = HTMLCurrency(4).innerText
Case "PLN"
PLN = HTMLCurrency(4).innerText
Case "RON"
RON = HTMLCurrency(4).innerText
Case "CZK"
CZK = HTMLCurrency(4).innerText
End Select
End If
Next i
Debug.Print "EUR - ", EUR; vbNewLine; "HRK - ", HRK; vbNewLine; "HUF - ", HUF; vbNewLine; "PLN - ", PLN; vbNewLine; _
"RON - ", RON; vbNewLine; "CZK - ", CZK
End Sub
'============================================================================
Sub WebConnection(HTMLDoc As MSHTML.HTMLDocument, ConnTest As Boolean, URL As String)
Dim XMLPage As New MSXML2.XMLHTTP60
Dim errorMsg As VbMsgBoxResult
On Error GoTo CONNECTION_ERROR
XMLPage.Open "GET", URL, False
XMLPage.send
On Error GoTo 0
If XMLPage.Status <> 200 Then
errorMsg = MsgBox("There is something wrong with webpage. Do you want to try to continue?", vbYesNo + vbCritical, "ERROR")
If errorMsg = vbNo Then
ConnTest = False
Exit Sub
End If
End If
HTMLDoc.body.innerHTML = XMLPage.responseText
Exit Sub
CONNECTION_ERROR:
MsgBox "There is something wrong with the connection.", vbCritical, "ERROR"
ConnTest = False
Exit Sub
End Sub
I tried to use id (index:srednjiKursList:tbody_element) or class name(tableCell) but it doesn't work. This website is built in a different way
Your original link, let's call it the landing page, is dynamically loaded. Your GET request is too quick to retrieve the required info.
There is an alternative URL you can use.
When you go to the landing page you show it actually issues an XMLHTTP GET request to the following page:
The above is from using fiddler but you could inspect the web traffic with, for example, Chrome dev tools (F12).
You can input that URL directly into your code and it works perfectly.
Whole table:
You can also grab the whole table as follows:
Option Explicit
Public Sub GetInfo()
Dim html As New HTMLDocument, hTable As HTMLTable, clipboard As Object
Const URL = "https://www.nbs.rs/kursnaListaModul/srednjiKurs.faces?lang=eng"
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.send
html.body.innerHTML = StrConv(.responseBody, vbUnicode)
End With
Set hTable = html.getElementById("index:srednjiKursLista")
Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
clipboard.SetText hTable.outerHTML
clipboard.PutInClipboard
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).PasteSpecial
End Sub
Sample of results:
Just the listed currencies:
You could also use a little maths, based on table structure, to get just those elements you listed.
Option Explicit
Public Sub GetInfo()
Dim html As New HTMLDocument, hTable As HTMLTable, clipboard As Object
Const URL = "https://www.nbs.rs/kursnaListaModul/srednjiKurs.faces?lang=eng"
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.send
html.body.innerHTML = StrConv(.responseBody, vbUnicode)
End With
Set hTable = html.getElementById("index:srednjiKursLista")
Dim list As Object, i As Long
Dim EUR As Double, CZK As Double, HRK As Double, HUF As Double, PLN As Double, RON As Double, RSD As Double
Set list = hTable.querySelectorAll("td")
For i = 2 To list.Length - 1 Step 5
Select Case list.item(i).innerText
Case "EUR"
EUR = list.item(i + 2).innerText
Case "HRK"
HRK = list.item(i + 2).innerText
Case "HUF"
HUF = list.item(i + 2).innerText
Case "PLN"
PLN = list.item(i + 2).innerText
Case "RON"
RON = list.item(i + 2).innerText
Case "CZK"
CZK = list.item(i + 2).innerText
End Select
Next
Debug.Print "EUR - ", EUR; vbNewLine; "HRK - ", HRK; vbNewLine; "HUF - ", HUF; vbNewLine; "PLN - ", PLN; vbNewLine; _
"RON - ", RON; vbNewLine; "CZK - ", CZK
End Sub
Using the clipboard:
The following line:
GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
adds a late bound reference to Microsoft Forms Object Library so you can access the clipboard.
You could also either add a userform to your project or go VBE > Tools > references > Microsoft Forms Object Library to have access: