When I run this script it stops when the “For” loop starts with the error : Run-time error ‘424’ Object required.
Any idea what I’m missing?
Sub getdata()
Dim XMLReq As New MSXML2.XMLHTTP60
Dim JsonText As String
Dim jsonObject As Object, item As Object
Dim i As Long
XMLReq.Open "POST", "https://es.investing.com/stock-screener/Service/SearchStocks", False
XMLReq.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
XMLReq.setRequestHeader "Accept", "application/json"
XMLReq.setRequestHeader "X-Requested-With", "XMLHttpRequest"
XMLReq.send "country%5B%5D=5&exchange%5B%5D=95&exchange%5B%5D=2&exchange%5B%5D=1§or=5%2C12%2C3%2C8%2C9%2C1%2C7%2C6%2C2%2C11%2C4%2C10&industry=74%2C56%2C73%2C29%2C25%2C4%2C47%2C12%2C8%2C44%2C52%2C45%2C71%2C99%2C65%2C70%2C98%2C40%2C39%2C42%2C92%2C101%2C6%2C30%2C59%2C77%2C100%2C9%2C50%2C46%2C88%2C94%2C62%2C75%2C14%2C51%2C93%2C96%2C34%2C55%2C57%2C76%2C66%2C5%2C3%2C41%2C87%2C67%2C85%2C16%2C90%2C53%2C32%2C27%2C48%2C24%2C20%2C54%2C33%2C19%2C95%2C18%2C22%2C60%2C17%2C11%2C35%2C31%2C43%2C97%2C81%2C69%2C102%2C72%2C36%2C78%2C10%2C86%2C7%2C21%2C2%2C13%2C84%2C1%2C23%2C79%2C58%2C49%2C38%2C89%2C63%2C64%2C80%2C37%2C28%2C82%2C91%2C61%2C26%2C15%2C83%2C68&equityType=ORD%2CDRC%2CPreferred%2CUnit%2CClosedEnd%2CREIT%2CELKS%2COpenEnd%2CRight%2CParticipationShare%2CCapitalSecurity%2CPerpetualCapitalSecurity%2CGuaranteeCertificate%2CIGC%2CWarrant%2CSeniorNote%2CDebenture%2CETF%2CADR%2CETC%2CETN&eq_market_cap%5Bmin%5D=110630000&eq_market_cap%5Bmax%5D=1990000000000&pn=1&order%5Bcol%5D=eq_market_cap&order%5Bdir%5D=d"
If XMLReq.Status <> 200 Then
MsgBox "problem" & vbNewLine & XMLReq.Status & "- " & XMLReq.statusText
Exit Sub
End If
Set jsonObject = JsonConverter.ParseJson(XMLReq.responseText)
For Each item In jsonObject
Debug.Print item("stock_symbol")
Debug.Print item("symbol")
Debug.Print item("exchange_trans")
Debug.Print item("industry_trans")
Debug.Print item("last_eu")
Debug.Print item("pair_change_percent_eu")
Debug.Print item("eq_market_cap_eu")
Debug.Print item("totalCount")
Debug.Print item("link")
Next
End Sub
I finally found my mistake... The JSON structure comes as a single object with two objects inside. I'should have added the name of the second object to get what I need.
here is the line corrected:
For Each item In jsonObject("hits")
Related
I have working code that requests information from a website.
When I send the file to another PC and run the code, I get:
"Run-time error'91': Object variable or With block variable not set"
I ensured:
Macro security levels are the same (Enable all macros & trust access to VBA project object model)
All the checked boxes in VBA editor > Tools > References are the same (Specifically Microsoft HTML Object Library & Microsoft XML, V6.0 is checked)
Sub Macro1()
Dim request As Object
Dim response As String
Dim html As New HTMLDocument
Dim website As String
Dim Current As Variant
website = "https://www.thalia.de/shop/home/artikeldetails/A1062020980"
Set request = CreateObject("MSXML2.XMLHTTP")
request.Open "GET", website, False
request.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
request.send
response = StrConv(request.responseBody, vbUnicode)
html.body.innerHTML = response
Current = html.getElementsByClassName("element-text-standard value").Item(0).innerText
MsgBox (Current)
End Sub
The line on which I get the error:
Current = html.getElementsByClassName("element-text-standard value").Item(0).innerText
WinHttp
I've tried a ton of various solutions, in the end, it came just to replacing MSXML2.XMLHTTP with WinHttp.WinHttpRequest.5.1 to make it work on my computer. While I was researching, I rewrote the whole thing a little bit. I'm a noob at this so I can't explain why one works and the other does not.
Option Explicit
Sub Macro1()
Const URL As String _
= "https://www.thalia.de/shop/home/artikeldetails/A1062020980"
'Const URL As String _
= "https://www.thalia.de/shop/home/artikeldetails/A1060523771"
Const ClassName As String _
= "element-text-standard value"
Dim WhrResponseText As String
WhrResponseText = GetWhrResponseText(URL)
If Len(WhrResponseText) = 0 Then
MsgBox "Could not get a response.", vbExclamation
Exit Sub
End If
' ' Write the response string to a worksheet.
' Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Dim arr() As String: arr = Split(WhrResponseText, vbLf)
' ws.Range("A1").Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
Dim Elements As Object
With CreateObject("htmlfile")
.body.innerHTML = WhrResponseText
Set Elements = .getElementsByClassName(ClassName)
End With
' Using 'Length' to determine if a result was found and returning
' the first element.
Dim Result As Variant
With Elements
If .Length > 0 Then
Result = .Item(0).innerText
MsgBox Result
Else
MsgBox "Nothing found."
End If
End With
Dim i As Long
' Loop through the elements using 'For Each... Next'.
Dim Element As Object
For Each Element In Elements
Debug.Print i, Element.innerText
i = i + 1
Next Element
' ' Loop through the elements using 'For... Next'.
' With Elements
' For i = 0 To .Length - 1
' Debug.Print i, .Item(i).innerText
' Next i
' End With
End Sub
Function GetWhrResponseText( _
ByVal URL As String) _
As String
Const ProcName As String = "GetWhrResponseText"
On Error GoTo ClearError
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", URL, False
.send
GetWhrResponseText = StrConv(.responseBody, vbUnicode)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
I'm trying to make an Excel Macro to automatically shorten URLs in an Excel file.
().
I found existing code however this applies to an old version of the API:
Bitly has instructions on how to connect to the new API version, however these are not written in VBA:
The Bitly API instructions also contain instructions on how to convert a V3 API call to a V4 API call:
I tried to fix this. In Excel I get the error
'{"message":"FORBIDDEN"'
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim objHTTP As Object
Dim Json, URL, result, AccToken, LongURL As String
If Not Intersect(Target, Range("B6:B100")) Is Nothing Then
If Target.Count > 1 Then Exit Sub 'If users selects more than one cell, exit sub to prevent bugs
If Target.Value = Empty Then Exit Sub
AccToken = Sheet1.Range("C4").Value
If AccToken = "" Then
MsgBox "Please enter your Bitly Access Token to get started" & vbCrLf & "hoi"
Exit Sub
End If
LongURL = Target.Value
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
URL = "https://api-ssl.bitly.com/v4/shorten"
objHTTP.Open "POST", URL, LongURL, False
objHTTP.setRequestHeader "Authorization", "Bearer {" & AccToken & "}"
'objHTTP.setRequestHeader "Authorization", "Bearer {TOKEN}"
objHTTP.setRequestHeader "Content-type", "application/json"
objHTTP.send (Json)
result = objHTTP.responseText
Range("C" & Target.Row).Value = Left(result, Len(result) - 1)
Set objHTTP = Nothing
End If
End Sub
AccToken should be without brackets { } like: objHTTP.setRequestHeader "Authorization", "Bearer " & AccToken
You Dim Json but you set no value to this variable (it is empty) and so you send and empty request objHTTP.send (Json).
Your LongURL shoud not go into tho .Open but into your JSON so it needs to be objHTTP.Open "POST", URL, False and Json = "{""long_url"": ""https://dev.bitly.com"", ""domain"": ""bit.ly"", ""group_guid"": ""Ba1bc23dE4F""}"
It should look something like below:
If Not Intersect(Target, Me.Range("B6:B100")) Is Nothing Then
If Target.Count > 1 Then Exit Sub 'If users selects more than one cell, exit sub to prevent bugs
If Target.Value = vbNullString Then Exit Sub
Dim AccToken As String
AccToken = Sheet1.Range("C4").Value
If AccToken = vbNullString Then
MsgBox "Please enter your Bitly Access Token to get started" & vbCrLf & "hoi"
Exit Sub
End If
Dim LongURL As String
LongURL = Target.Value
Dim objHTTP As Object
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
Dim URL As String
URL = "https://api-ssl.bitly.com/v4/shorten"
objHTTP.Open "POST", URL, False
objHTTP.setRequestHeader "Authorization", "Bearer " & AccToken
objHTTP.setRequestHeader "Content-type", "application/json"
Dim Json As String
Json = "{""long_url"": """ & LongURL & """, ""domain"": ""bit.ly"", ""group_guid"": ""Ba1bc23dE4F""}"
objHTTP.send Json
Dim result As String
result = objHTTP.responseText
Me.Range("C" & Target.Row).Value = Left(result, Len(result) - 1)
Set objHTTP = Nothing
End If
I have been using below code to convert the data from JSON to Excel but below JSON format is not converting into excel and having an error Run time error: Invalid procedure call or argument on the line ws.Cells(r, "C").Value = JSON("sku")
Here is my code that i have been using. I do not know why the error is appearing when it works for other JSON format instead of this one.
Your help will be appreciated.
Dim objRequest As Object
Dim strUrl As String
Dim blnAsync As Boolean
Dim strResponse As String
Dim idno As Long
Dim ws As Worksheet
Dim JSON As Object
Dim lrow As Long
Set ws = Sheet4
lrow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
Set objRequest = CreateObject("MSXML2.XMLHTTP")
strUrl = "url"
blnAsync = True
With objRequest
.Open "GET", strUrl, blnAsync
.setRequestHeader "Content-Type", "application/json"
.send
While objRequest.readyState <> 4
DoEvents
Wend
strResponse = .ResponseText
End With
Set JSON = ParseJson(strResponse)
' Debug.Print strResponse
r = 2
ws.Cells(r, "C").Value = JSON("sku")
'r = r + 1
I'm not sure if there is a option for this in JSONConverter but as far as I know, it doesn't like to parse JSON string that starts with a collection so I would usually create a key manually so that it will convert properly.
Below example also shows how you can loop through the collection and get the value for sku:
'.... Continue after you post the API...
Dim strResponse As String
strResponse = .responseText
Dim resultDict As Object
Set resultDict = ParseJson("{""result"":" & strResponse & "}")
Dim i As Long
Dim resultNum As Long
resultNum = resultDict("result").Count
For i = 1 To resultNum
Debug.Print resultDict("result")(i)("id")
Debug.Print resultDict("result")(i)("sku")
Debug.Print resultDict("result")(i)("upc")
'Loop through skuList collection
Dim j As Long
For j = 1 To resultDict("result")(i)("skuList").Count
Debug.Print vbTab & resultDict("result")(i)("skuList")(j)("id")
Debug.Print vbTab & resultDict("result")(i)("skuList")(j)("sku")
Debug.Print vbTab & resultDict("result")(i)("skuList")(j)("skuTitle")
Next j
Next i
I have tried using API for get some information for Yahoo Finance
And this is the UDF that I created
Sub Test()
'1 >> High & 2 >> Close
MsgBox YahooHigh("GOOG", "2019-07-18", 1)
MsgBox YahooHigh("GOOG", "2019-07-18", 2)
End Sub
Function YahooHigh(sTicker As String, sDate As String, idx As Integer)
Dim json As Object
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", "https://www.alphavantage.co/query?function=TIME_SERIES_DAILY&symbol=" & sTicker & "&outputsize=full&apikey=myapikey"
.Send
Set json = JsonConverter.ParseJson(.responseText)
End With
If idx = 1 Then
YahooHigh = json("Time Series (Daily)")(sDate)("2. high")
ElseIf idx = 2 Then
YahooHigh = json("Time Series (Daily)")(sDate)("4. close")
Else
YahooHigh = Empty
End If
End Function
The UDF works fine but of course I will have to load the JSON result each time. As in my example, the UDF will run for twice the first for High value and the second for the Close value
Is there a way to store the json results into an array then instead of loading the json, the array is called. I thought of static but I am stuck at this
What I would like to do is to store all the dates in the json results for specific ticker (High value and Close value only) then to recall the desired value from the static array .. Any ideas?
Another variation:
I have tried using the HTML content and it works fine for me when using the link directly
Sub MyTest()
Dim html As Object, ele As Object
With CreateObject("MSXML2.ServerXMLHTTP")
'https://finance.yahoo.com/quote/GOOG/history?period1=1325566800&period2=1325566800&interval=1d&filter=history&frequency=1d
'.Open "GET", "https://finance.yahoo.com/quote/GOOG/history?period1=1325566800&period2=1325566800&interval=1d&filter=history&frequency=1d", False
Dim sTicker As String
sTicker = Sheets(1).Range("B1").Value 'GOOG
Dim period1 As Long, period2 As Long
period1 = ToUnix(Sheets(1).Range("B2").Value) '3 Jan 2012
period2 = ToUnix(Sheets(1).Range("B3").Value) '3 Jan 2012
.Open "GET", "https://finance.yahoo.com/quote/" & sTicker & "/history?period1=" & period1 & "&period2=" & period2 & "&interval=1d&filter=history&frequency=1d", False
.Send
If .Status <> 200 Then MsgBox "Problem" & vbNewLine & .Status & " - " & .StatusText: Exit Sub
Set html = CreateObject("htmlfile")
html.body.innerHTML = .responseText
'WriteTxtFile html.body.innerHTML
'Stop
Set ele = html.getElementsByTagName("table")(0).getElementsByTagName("tr")(1)
Dim tCell As Object
Dim cnt As Long
For Each tCell In ele.Children
cnt = cnt + 1
If cnt = 3 Then Debug.Print "High: " & tCell.innerText
If cnt = 5 Then Debug.Print "Close: " & tCell.innerText
Next tCell
End With
End Sub
Public Function ToUnix(dt) As Long
ToUnix = DateDiff("s", "1/1/1970", dt)
End Function
When using this line .Open "GET", "https://finance.yahoo.com/quote/GOOG/history?period1=1325566800&period2=1325566800&interval=1d&filter=history&frequency=1d", False it works fine and returns values from High and Close
But when trying to convert the dates from the worksheet to UNIX so as to use them in the link, it doesn't work
This is the problem for me now
Just have your function return the json object, then parse it in your sub.
The json object will contain all your data, and you can parse out what you want.
For example
In your function:
Function YahooHigh(sTicker As String) as object
Dim json As Object
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", "https://www.alphavantage.co/query?function=TIME_SERIES_DAILY&symbol=" & sTicker & "&outputsize=full&apikey=myapikey"
.Send
Set YahooHigh = JsonConverter.ParseJson(.responseText)
End With
and in your Sub:
Sub Test()
Dim obj As Object
Set obj = YahooHigh("GOOG")
MsgBox obj("Time Series (Daily)")("2019-07-18")("2. high")
MsgBox obj("Time Series (Daily)")("2019-07-18")("4. close")
End Sub
I'm attempting to pull data from a JSON file on the web. I'm using a dummy JSON file for the time being to get things working. My code is below, but it times out every time and doesn't return anything. The same happens if I use different URLs also.
Sub Test()
Dim strResult As String
Dim objHTTP As Object
Dim URL As String
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
URL = "https://jsonplaceholder.typicode.com/posts/2"
objHTTP.Open "GET", URL, False
objHTTP.Send
strResult = objHTTP.ResponseText
MsgBox strResult
End Sub
In case it's relevant, I have the following libraries enabled in the file:
Visual Basic for Applications
Microsoft Excel 15.0 Object Library
OLE Automation
Microsoft Scripting Runtime
Microsoft WinHTTP Services, version 5.1
What am I missing?
EDIT: Fixed. I wasn't aware of the distinction between WinHttpRequest and XMLHTTPRequest. When using the latter, the code worked fine. Thanks all.
Is there a special reason why using WinHttpRequest instead of XMLHTTPRequest?
While using WinHttpRequest the operating system defaults for HTTP requests - proxy settings for example - are not used and must be set explicitly:
Sub Test()
Dim strResult As String
Dim objHTTP As Object
Dim URL As String
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
objHTTP.SetProxy 2, "proxyIP:proxyPort"
URL = "https://jsonplaceholder.typicode.com/posts/2"
objHTTP.Open "GET", URL, False
objHTTP.setCredentials "username", "password", 1
objHTTP.Send
strResult = objHTTP.ResponseText
MsgBox strResult
End Sub
The 2 in IWinHttpRequest::SetProxy method is HTTPREQUEST_PROXYSETTING_PROXY.
The 1 in IWinHttpRequest::SetCredentials method is HTTPREQUEST_SETCREDENTIALS_FOR_PROXY.
While using XMLHTTPRequest the operating system defaults for HTTP requests are used as set in Internet Options in control panel. So the following should run if you are able accessing the URL via browser:
Sub Test()
Dim strResult As String
Dim objHTTP As Object
Dim URL As String
Set objHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
URL = "https://jsonplaceholder.typicode.com/posts/2"
objHTTP.Open "GET", URL, False
objHTTP.Send
strResult = objHTTP.ResponseText
MsgBox strResult
End Sub
Your code works OK here, but perhaps you should .WaitForResponse if things are timing out:
Sub Test()
Dim strResult As String
Dim objHTTP As Object
Dim URL As String
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
URL = "https://jsonplaceholder.typicode.com/posts/2"
objHTTP.Open "GET", URL, False
objHTTP.Send
objHTTP.waitforresponse
strResult = objHTTP.ResponseText
MsgBox strResult
End Sub