Related
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
I'm trying to download a xlsx file from a password protected website to use in PBI.
On PBI I already tried to use Power Query and the Web Connector. I also tried using Power Automate (online version with HTTP connector, since my desktop version doesn't run on background).
And finally I'm using VBA. But all of them returns a file with the website HTML code, instead of the data which should be in the xlsx.
The code from the last try with VBA (which I found here is bellow (with a generic website URL)):
Sub DownloadFile()
Dim evalURL As String
Dim streamObject As Object
Dim winHttpRequest As Object
Set winHttpRequest = CreateObject("Microsoft.XMLHTTP")
evalURL = "https://generic_website.com/Excel_file.xslx" '
winHttpRequest.Open "GET", evalURL, False, "username", "password"
winHttpRequest.send
If winHttpRequest.Status = 200 Then
Set streamObject = CreateObject("ADODB.Stream")
streamObject.Open
streamObject.Type = 1
streamObject.Write winHttpRequest.responseBody
streamObject.SaveToFile "C:\Users\MyUser\Downloads\Excel_file.xslx", 2 ' 1 = no overwrite, 2 = overwrite
streamObject.Close
End If
End Sub
If I log into the website and open the URL directly in a browser, it downloads the .xlsx file.
Is there any way to do that? I have no idea what's happening, since the same code worked to other people.
UPDATE:
I tried the VBA code bellow, and get the results you can see in the image here.
Sub Login()
Dim response As String
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", "https://generic_website.com/Excel_file.xslx", False, "username", "password"
.send
response = .responseText
End With
MsgBox response
End Sub
I do not know if this works as I cant login, and dont know the file. hopefully it can point you in the right direction.
' VBA Editor->Tools->References
' find and select the following
' Microsoft WinHTTP Services,version 5.1
' Microsoft HTML Object Library
Sub GetFile()
Dim URL As String: URL = "your url"
Dim File As String: File = "your url/file.xslx"
Dim Email As String: Email = "your#address.com"
Dim Password As String: Password = "Your Password"
Dim Cookie As String
Dim Token As String
Dim Message As String
Dim HTML As HTMLDocument: Set HTML = New HTMLDocument
Dim HTTP As WinHttpRequest: Set HTTP = New WinHttpRequest
' you potentially need the csrf_token to post the login form.
' so we get the token, and any cookies sent
HTTP.Open "GET", URL, True
HTTP.Send
HTTP.WaitForResponse
HTML.body.innerHTML = HTTP.ResponseText
Cookie = HTTP.GetResponseHeader("Set-Cookie")
Token = HTML.getElementsByName("csrf_token")(0).Value
Message = "csrf_token=" & Token & "&email=" & URLEncode(Email) & "&senha=" & URLEncode(Password)
HTTP.Open "POST", URL, True
HTTP.SetRequestHeader "Content-type", "application/x-www-form-urlencoded"
HTTP.SetRequestHeader "Cookie", Cookie
HTTP.Send Message
HTTP.WaitForResponse
Cookie = HTTP.GetResponseHeader("Set-Cookie")
' i dont have credentials so dont know what happens after this point and cannot test any further
HTTP.Open "GET", File, True
HTTP.SetRequestHeader "Cookie", Cookie
HTTP.Send
HTTP.WaitForResponse
msgbox HTTP.responseText
' if the runtime error still occurs then not sure what to do
' however,
' if the above message box looks like HTML, it didnt work.
' if it doesn't, it MIGHT have worked, you just need to
' figure out how to save the data to a file
'Dim FileNumber As Integer: FileNumber = FreeFile()
'Open "C:\destination.xslx" For Binary Access Write As #FileNumber
'Put #FileNumber, 1, HTTP.ResponseBody
'Close #FileNumber
End Sub
'https://stackoverflow.com/a/218199/212869
Public Function URLEncode(StringVal As String) As String
Dim StringLen As Long: StringLen = Len(StringVal)
If StringLen > 0 Then
ReDim result(StringLen) As String
Dim i As Long, CharCode As Integer
Dim Char As String
For i = 1 To StringLen
Char = Mid$(StringVal, i, 1)
CharCode = Asc(Char)
Select Case CharCode
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
result(i) = Char
Case 32
result(i) = "+"
Case 0 To 15
result(i) = "%0" & Hex(CharCode)
Case Else
result(i) = "%" & Hex(CharCode)
End Select
Next i
URLEncode = Join(result, "")
End If
End Function
I am working on a code to get data from : https://www.investing.com/economic-calendar/core-durable-goods-orders-59
I have got the code for getting this via httprequest: but looking to change this to work for the economic data (link above) is there any way I can get the same for the economic indicators??
code below:
Option Explicit
Sub Export_Table()
'Html Objects---------------------------------------'
Dim htmlDoc As MSHTML.HTMLDocument
Dim htmlBody As MSHTML.htmlBody
Dim ieTable As MSHTML.HTMLTable
Dim Element As MSHTML.HTMLElementCollection
'Workbooks, Worksheets, Ranges, LastRow, Incrementers ----------------'
Dim wb As Workbook
Dim Table As Worksheet
Dim i As Long
Set wb = ThisWorkbook
Set Table = wb.Worksheets("Sheet1")
'-------------------------------------------'
Dim xmlHttpRequest As New MSXML2.XMLHTTP60 '
'-------------------------------------------'
i = 2
'Web Request --------------------------------------------------------------------------'
With xmlHttpRequest
.Open "POST", "https://www.investing.com/instruments/HistoricalDataAjax", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "X-Requested-With", "XMLHttpRequest"
.send "curr_id=951681&smlID=1695217&header=CLNX+Historical+Data&st_date=01%2F01%2F2017&end_date=03%2F01%2F2019&interval_sec=Monthly&sort_col=date&sort_ord=DESC&action=historical_data"
If .Status = 200 Then
Set htmlDoc = CreateHTMLDoc
Set htmlBody = htmlDoc.body
htmlBody.innerHTML = xmlHttpRequest.responseText
Set ieTable = htmlDoc.getElementById("curr_table")
For Each Element In ieTable.getElementsByTagName("tr")
Table.Cells(i, 1) = Element.Children(0).innerText
Table.Cells(i, 2) = Element.Children(1).innerText
Table.Cells(i, 3) = Element.Children(2).innerText
Table.Cells(i, 4) = Element.Children(3).innerText
Table.Cells(i, 5) = Element.Children(4).innerText
Table.Cells(i, 6) = Element.Children(5).innerText
Table.Cells(i, 7) = Element.Children(6).innerText
i = i + 1
DoEvents: Next Element
End If
End With
Set xmlHttpRequest = Nothing
Set htmlDoc = Nothing
Set htmlBody = Nothing
Set ieTable = Nothing
Set Element = Nothing
End Sub
Public Function CreateHTMLDoc() As MSHTML.HTMLDocument
Set CreateHTMLDoc = CreateObject("htmlfile")
End Function
I have used the excel tool Power Query for this very thing. It is also called Get & Transform Data. I don't like using vba for doing this type of thing.
To make it work:
In Excel Go to Data>Get Data>From Other Sources>From Web.
Enter the URL
Wait for the webpage to load and then pick the table that you want.
This website took awhile to load, but it did work for me.
Choose "Load" which goes directly to the sheet, or "Transform Data" to manipulate the data in Power Query. There are many options in power query such as split columns, filter data, Calculate Columns and ...
I would avoid the overhead of setting up a permanent connection and simply continue using XHR. With the data > from web, you cannot grab more rows than are present on the initial landing. If however you go with XHR, you can issue POST requests to get more data. The code below utilizes a loop to retrieve additional results beyond the immediate visible on the page.
When you press the Show more link there is a POST request for an additional 6 rows which uses the latest date from the current set of results as part of the POST body. The response returned is JSON. Rather than bringing in a JSON parser, given the standard nature of the JSON, and that I am already using regex to clean the date format in column 1 to put in the POST body, I use two simple regexes to extract the html for the next results table from the response, and to check whether there are more results.
The format of the JSON is:
{
"historyRows": "<tr>…..</tr>",
"hasMoreHistory": "1"
}
Or
{
"historyRows": "<tr>…..</tr>",
"hasMoreHistory": false
}
So, I do some cleaning of the extracted html in order to not confuse the html parser within MSHTML. Furthermore, I add in an id to identify the table I have constructed, so I can continue to use an id css selector (#) list within my UpdateDateResults function.
I initially oversize an array to store each retrieved table which I update ByRef. I loop requesting more results until either there are no more results, there is an error parsing the maximum date from the last retrieved table column 1, or until my specified earliest date for data retrieval falls within the date range of the latest returned table.
Finally, I write the results array out to the sheet in one go.
N.B. You can target the table by its id. It looks like the number at the end of the id could be the same as for the goods url, lending itself to generalizing the code below to work for other goods.
VBA:
Option Explicit
Public Sub GetInvestingInfo()
'tools > references > Microsoft HTML Object Library
Dim html As MSHTML.HTMLDocument, xhr As Object
Const STARTDATE As Date = "2019-11-25" 'Adjust as required. DateAdd("yyyy", -2, Date) 2 years back. This means may have some earlier months in _
batch that spans the start date but won't issue an additional request after this
Set xhr = CreateObject("MSXML2.XMLHTTP")
Set html = New MSHTML.HTMLDocument
With xhr
.Open "GET", "https://www.investing.com/economic-calendar/core-durable-goods-orders-59", False
.setRequestHeader "User-Agent", "Safari/537.36"
.send
html.body.innerHTML = .responseText
End With
Dim firstTable As Boolean, r As Long, results() As Variant
ReDim results(1 To 100000, 1 To 5)
'process initial table and update results, get cleaned date needed for request for more results
firstTable = True
Dim latestDate As String
UpdateDateResults latestDate, results, firstTable, r, html
Dim re As Object, maxDate As String, hasMoreHistory As Boolean, s As String
Set re = CreateObject("VBScript.RegExp")
With re
.Global = True
.MultiLine = False
End With
maxDate = cleanedDate(latestDate, re)
hasMoreHistory = True
Dim errorDate As Date
errorDate = DateAdd("d", 1, Date)
Do While maxDate >= STARTDATE And maxDate < errorDate 'break loop using pre-defined earliest date, error with date conversion, or when no more rows found
Application.Wait (Now + TimeSerial(0, 0, 1)) 'Pause
s = GetMoreRows(xhr, Format$(maxDate, "YYYY-MM-DD")) 'max a POST request for more data
re.Pattern = "hasMoreHistory"":(""?.*?""?)}" 'Check if there are more rows still available. "1" for yes, false for no
hasMoreHistory = (re.Execute(s)(0).submatches(0) <> False)
If Not hasMoreHistory Then Exit Do
re.Pattern = "historyRows"":""(.*)"","
html.body.innerHTML = "<table id=""me"">" & Replace$(re.Execute(s)(0).submatches(0), "\/", "/") & "</table>" 'fix html and feed into html variable
UpdateDateResults latestDate, results, firstTable, r, html
maxDate = cleanedDate(latestDate, re) 'convert value retrieved from last row in date column of table to an actual date
Loop
With ActiveSheet
.Cells.ClearContents
.Cells(1, 1).Resize(r, 5) = results 'Don't bother to resize results as clear all cells before write ou
End With
End Sub
Public Sub UpdateDateResults(ByRef latestDate As String, ByRef results() As Variant, ByRef firstTable As Boolean, ByRef r As Long, ByVal html As MSHTML.HTMLDocument)
Dim table As MSHTML.HTMLTable 'return latest date from function
Set table = html.querySelector("#eventHistoryTable59, #me")
latestDate = table.Rows(table.Rows.Length - 1).Children(0).innerText
Dim i As Long, n As Long, j As Long
n = IIf(firstTable, 0, 1)
For i = n To table.Rows.Length - 1
r = r + 1
For j = 0 To table.Rows(i).Children.Length - 2
results(r, j + 1) = table.Rows(i).Children(j).innerText
Next
Next
firstTable = False
End Sub
Public Function cleanedDate(ByVal dirtyString As String, ByVal re As Object) As Date
re.Pattern = "(^[A-Z][a-z]{2}).*(\d{2}),.(\d{4})(.*)"
On Error GoTo errhand:
If re.test(dirtyString) Then
cleanedDate = CDate(re.Replace(dirtyString, "$2" & Chr$(32) & "$1" & Chr$(32) & "$3"))
Exit Function
End If
errhand:
cleanedDate = DateAdd("d", 1, Date)
End Function
Public Function GetMoreRows(ByVal xhr As Object, ByVal dateStamp As String) As String
With xhr
.Open "POST", "https://www.investing.com/economic-calendar/more-history", False
.setRequestHeader "User-Agent", "Safari/537.36"
.setRequestHeader "x-requested-with", "XMLHttpRequest"
.setRequestHeader "content-type", "application/x-www-form-urlencoded"
.send "eventID=430865&event_attr_ID=59&event_timestamp=" & dateStamp & "+" & Application.WorksheetFunction.EncodeURL("12:30:00") & "&is_speech=0"
GetMoreRows = .responseText
End With
End Function
Regexes (without the double " escaping for VBA):
hasMoreHistory":("?.*?"?)}
historyRows":"(.*)",
The URL from Yahoo is not working when I try to retrieve quotes from a particular stock. There are several discussion about it, However, it seems nothing is shown regarding VBA macro
Sub Get_Data()
Dim URL As String
Dim Ticker As String
Dim http As New WinHttpRequest
Dim sCotes As String
Dim Lignes
Dim Valeurs
Dim i As Long
Dim j As Long
Dim sLigne As String
Dim sValeur As String
Ticker = Range("Ticker")
URL = "https://query1.finance.yahoo.com/v7/finance/download/TECK?period1=1540456339&period2=1571992339&interval=1d&events=history&crumb=kjOZLFv6ch2"
http.Send
sCotes = http.ResponseText
MsgBox sCotes
Lignes = Split(sCotes, Chr(10))
For i = 1 To UBound(Lignes) 'until the end of the Lignes variable
sLigne = Lignes(i)
Valeurs = Split(sLigne, ",")
For j = 0 To UBound(Valeurs) - 1
Select Case j
Case 0
sValeur = DateSerial(CLng(Left(Valeurs(0), 4)), CLng(Mid(Valeurs(0), 6, 2)), CLng(Right(Valeurs(0), 2)))
Case 5
sValeur = CLng(Valeurs(5))
Case Else
sValeur = CDbl(Replace(Valeurs(j), ".", ","))
End Select
Range("A1").Offset(i, j) = sValeur
Application.StatusBar = Format(Cells(i, 1), "Short Date")
Next
Next
Application.StatusBar = False
End Sub
Execution error at the step Http.send : "This method cannot be called until the Open method has been called"
You would need to use the "open" method before attempting to send and GET is perfectly fine. However, a few things....
There is an easier way. The headers worth adding are the User-Agent and one to mitigate being served cached results. The following shows you how to get a json response from the server for a specified time period and write to Excel. Note: You need to concatenate the ticker into the url. You should probably also test the response code from server to ensure successful.
I use jsonconverter.bas as the json parser to handle response. Download raw code from here and add to standard module called JsonConverter . You then need to go VBE > Tools > References > Add reference to Microsoft Scripting Runtime. Remove the top Attribute line from the copied code.
The values for startDate and endDate need to be passed as unix timestamps. #TimWilliams wrote a nice function, toUnix, for converting Date to Unix here which I use. I have added my own function to manage the conversion in the opposite direction.
This method avoids using any session based identifiers so avoids your issue with invalid cookie crumb.
VBA:
Option Explicit
Public Sub GetYahooHistoricData()
Dim ticker As String, ws As Worksheet, url As String, s As String
Dim startDate As Long, endDate As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
ticker = ws.Range("ticker") 'Range A1. Above write out range
endDate = toUnix("2019-10-27")
startDate = toUnix("2018-10-25")
url = "https://query1.finance.yahoo.com/v8/finance/chart/" & ticker & "?region=US&lang=en-US&includePrePost=false&interval=1d&period1=" & startDate & "&period2=" & endDate & "&corsDomain=finance.yahoo.com&.tsrc=finance"
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", url, False
.setRequestHeader "User-Agent", "Mozilla/5.0"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
s = .responseText
End With
Dim json As Object
Set json = JsonConverter.ParseJson(s)("chart")("result")
Dim dates As Object, results(), rows As Object, adjClose As Object, r As Long, headers()
headers = Array("date", "close", "volume", "open", "high", "low", "adjclose")
Set dates = json(1)("timestamp")
ReDim results(1 To dates.Count, 1 To UBound(headers) + 1)
Set rows = json(1)("indicators")("quote")(1)
Set adjClose = json(1)("indicators")("adjclose")(1)("adjclose")
For r = 1 To dates.Count
results(r, 1) = GetDate(dates(r))
results(r, 2) = rows("close")(r)
results(r, 3) = rows("volume")(r)
results(r, 4) = rows("open")(r)
results(r, 5) = rows("high")(r)
results(r, 6) = rows("low")(r)
results(r, 7) = adjClose(r)
Next
With ws
.Cells(3, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(4, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End With
End Sub
Public Function GetDate(ByVal t As Variant) As String
GetDate = Format$(t / 86400 + DateValue("1970-01-01"), "yyyy-mm-dd")
End Function
Public Function toUnix(ByVal dt As Variant) As Long
toUnix = DateDiff("s", "1/1/1970", dt)
End Function
Example top 10 rows:
Try replacing this code
URL = "https://query1.finance.yahoo.com/v7/finance/download/TECK?period1=1540456339&period2=1571992339&interval=1d&events=history&crumb=kjOZLFv6ch2"
http.Send
with this code:
set http = Server.Createobject("MSXML2.ServerXMLHTTP.6.0")
URL = "https://query1.finance.yahoo.com/v7/finance/download/TECK?period1=1540456339&period2=1571992339&interval=1d&events=history&crumb=kjOZLFv6ch2"
http.open "POST", URL, False
http.Send
The error is pretty clear: you need to call the open method before the Send method. Also this would be a POST request. You also may need to put these two lines after the open method:
http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
http.setRequestHeader "Content-Length", 0
The question is about 99% duplicate as the one from here - How can I send an HTTP POST request to a server from Excel using VBA?. Anyway, the mistake is obviously, because the .Send() method simply sends a completely empty Dim http As New WinHttpRequest object.
To make the code work, copy the example from the duplcated question and print the http.ResponseText:
Sub TestMe()
Dim http As Object
Dim url As String
Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
url = "https://query1.finance.yahoo.com/v7/finance/download/TECK?period1=1540456339&period2=1571992339&interval=1d&events=history&crumb=kjOZLFv6ch2"
http.Open "POST", url, False
http.Send
MsgBox http.responsetext
End Sub
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: