JSON to VBA - Error 13 mismatch on "root values" - json

I was trying to get some information from a JSON API and everything was going OK. So I started to get mismatch errors when I try to parse values that are inside the “root” of the JSON.
The code I use is below:
Public Sub Times()
Dim http As Object, JSON As Object, i As Integer
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://api.cartolafc.globo.com/time/id/1084847/7", False
http.Send
Set JSON = ParseJson(http.responseText)
i = 2
Application.ScreenUpdating = False
Sheets("Youtube").Select
For Each Item In JSON
Sheets("Mais Escalados").Cells(i, 2).value = Item("pontos")
i = i + 1
Next
Application.ScreenUpdating = True
MsgBox ("Atualização Completa")
End Sub
I can parse the data inside atletas sub-items or any other header changing the code like this:
Sheets("Mais Escalados").Cells(i, 2).value = Item("atletas")("nome")
But when I try to parse information like pontos on the root I get the mismatch error.

This will give you the root value for the key "pontos":
JSON("pontos")
You can't loop over the root keys like you show in your posted code: you would need to check the type of each key's value before you try to write it to the sheet:
Public Sub Times()
Dim http As Object, JSON As Object, i As Integer, k
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://api.cartolafc.globo.com/time/id/1084847/7", False
http.Send
Set JSON = ParseJson(http.responseText)
For Each k In JSON
Debug.Print k, TypeName(JSON(k))
Next
End Sub
Output:
atletas Collection
clubes Dictionary
posicoes Dictionary
status Dictionary
capitao_id Double
time Dictionary
patrimonio Double
esquema_id Double
pontos Double
valor_time Double
rodada_atual Double

Related

How to retrieve JSON response using VBA?

I make a request to a website and paste the JSON response into a single cell.
I get an object required 424 error.
Sub GetJSON()
Dim hReq As Object
Dim JSON As Dictionary
Dim var As Variant
Dim ws As Worksheet
Set ws = Title
'create our URL string and pass the user entered information to it
Dim strUrl As String
strUrl = Range("M24").Value
Set hReq = CreateObject("MSXML2.XMLHTTP")
With hReq
.Open "GET", strUrl, False
.Send
End With
'wrap the response in a JSON root tag "data" to count returned objects
Dim response As String
response = "{""data"":" & hReq.responseText & "}"
Set JSON = JsonConverter.ParseJson(response)
'set array size to accept all returned objects
ReDim var(JSON("data").Count, 1)
Cells(25, 13) = JSON
Erase var
Set var = Nothing
Set hReq = Nothing
Set JSON = Nothing
End Sub
The URL that gives me the response in cell "M24":
https://earthquake.usgs.gov/ws/designmaps/asce7-10.json?latitude=36.497452&longitude=-86.949479&riskCategory=III&siteClass=C&title=Seismic
The code after Qharr's response. I get a run time 0 error even though the error says it ran successfully. Nothing is copied to my cells.
Public Sub GetInfo()
Dim URL As String, json As Object
Dim dict As Object
URL = "https://earthquake.usgs.gov/ws/designmaps/asce7-10.json?latitude=36.497452&longitude=-86.949479&riskCategory=III&siteClass=C&title=Seismic"
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.Send
Set json = JsonConverter.ParseJson(.responseText) '<== dictionary
ThisWorkbook.Worksheets("Title").Cells(1, 1) = .responseText
Set dict = json("response")("data")
ws.Cells(13, 27) = "ss: " & dict("ss") & Chr$(10) & "s1: " & dict("s1")
End With
End Sub
I'm not clear what you mean. The entire response can go in a cell as follows.
JSON is an object so you would need Set keyword but you can't set a cell range to the dictionary object - the source of your error.
Option Explicit
Public Sub GetInfo()
Dim URL As String, json As Object
URL = "https://earthquake.usgs.gov/ws/designmaps/asce7-10.json?latitude=36.497452&longitude=-86.949479&riskCategory=III&siteClass=C&title=Seismic"
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.send
Set json = JsonConverter.ParseJson(.responseText) '<== dictionary
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1) = .responseText
End With
End Sub
When you use parsejson you are converting to a dictionary object which you need to do something with. There is simply too much data nested inside to write anything readable (if limit not exceeded) into one cell.
Inner dictionary data quickly descends into nested collections. The nested collection count comes from
Dim dict As Object
Set dict = json("response")("data")
Debug.Print "nested collection count = " & dict("sdSpectrum").Count + dict("smSpectrum").Count
To get just s1 and ss values parse them out:
Dim dict As Object
Set dict = json("response")("data")
ws.Cells(1, 2) = "ss: " & dict("ss") & Chr$(10) & "s1: " & dict("s1")
I have figured out the solution to pasting the response text with Excel 2003. Below is my finished code.
Public Sub datagrab()
Dim URL As String
Dim ws As Object
Dim xmlhttp As New MSXML2.XMLHTTP60
URL = Range("M24").Value 'This is the URL I'm requesting from
xmlhttp.Open "GET", URL, False
xmlhttp.Send
Worksheets("Title").Range("M25").Value = xmlhttp.responseText
End Sub

Extracting specific JSON field from .responseText to single excel cell

I am trying to retrieve a particular field, resolve, from JSON. I am not sure as to how I can go about getting that one field. I added the Msgbox [Exists & Fail] to see if the code is able to read the word resolve within the cell, however i am returned with fail.
Is there any way i can get only the field resolve? Kindly assist.
Thank you!
TargetURL = "https://api.passivetotal.org/v2/dns/passive?query=passivetotal.org"
actionType = "Content-Type"
actionWord = "application/json"
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", TargetURL, False
.setRequestHeader actionType, actionWord
.setRequestHeader "Authorization", "Basic <Encoded 64>"
.send
If .Status = 200 Then
Sheets(6).Cells(Count, 10).Value = "Connected"
Debug.Print .responseText
MsgBox .responseText
Set JSON = ParseJson(.responseText)
Sheets(6).Cells(Count, 8).Value = .responseText
If Sheets(6).Cells(Count, 8).Value = ("resolve") Then
MsgBox ("Exists")
Else
MsgBox ("Fail")
End If
Else
MsgBox .Status & ": " & .StatusText
End If
End With
Parsing the JSON response:
The following reads in the results json from a file and parses out each resolve. It uses JSONConverter.bas. Note I have extracted the"results" JSON collection in my python script which would be the same as you doing json("results") on the converted JSON string via Set json = JsonConverter.ParseJson(.responseText)("results").
After adding JSONConverter.bas to your project you need to go tools > references > Add reference to Microsoft Scripting Runtime
Option Explicit
Public Sub GetJSONExtract()
Dim fso As Object, jsonFile As Object, jsonText As String, json As Object, item As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set jsonFile = fso.OpenTextFile("C:\Users\User\Desktop\Sample.json")
jsonText = jsonFile.ReadAll
Set json = JsonConverter.ParseJson(jsonText) '<== Using results collection
'Set json = JsonConverter.ParseJson(.responseText)("results") '<== In your vba XMLHTTP version
For Each item In json
Debug.Print item("resolve")
Next
End Sub
As you were after how to parse the JSON that it was I have shown.
Additional notes:
I actually used the python script shown below; adapted from the API documentation. I then added in a bit of code to write the response out to a JSON file for later import. Run using Anaconda/Spyder.
import requests
import json
username = 'xxx'
key = 'yyy'
auth = (username, key)
base_url = 'https://api.passivetotal.org'
def passivetotal_get(path, query):
url = base_url + path
data = {'query': query}
response = requests.get(url, auth=auth, json=data)
return response.json()
pdns_results = passivetotal_get('/v2/dns/passive', 'passivetotal.org')
for resolve in pdns_results['results']:
print('Found resolution: {}'.format(resolve['resolve']))
with open(r"C:\Users\User\Desktop\Output.json", "w") as text_file:
text_file.write(json.dumps(pdns_results['results']))
That prints out all the resolves.
The original returned JSON structure looks like:
The object returned is a collection of dictionaries. You access the required value by the dictionary key "resolve"

How can you extract a nested JSON value?

Can someone with experience using JSON and Access together tell me what I'm doing wrong with this code? I'm trying to parse a JSON file and there's one nested data item that I can't seem to extract. The problem portion of the JSON data is as follows:
credits":{
"director":[{"displayName":"Bradley Cooper","firstName":"Bradley","lastName":"Cooper","bio":""}],
"cast":["Bradley Cooper"," Lady Gaga"," Andrew Dice Clay"," Dave Chappelle"," Sam Elliott"]
}
I can extract the cast names with no problem, but I can't retrieve the "displayname" for the director. The nested "{}" brackets inside the "director" item are throwing me off. Here's my code:
Sub JSON_prob_demo()
Dim url As String, data As String
Dim xml As Object, JSON As Object, colObj As Object, colobj2 As Object, colObj3 As Object, item As Object
Dim c1 As Variant, varX As Variant
url = "https://www.tiff.net/data/films/a-star-is-born.json"
Set xml = CreateObject("MSXML2.XMLHTTP")
With xml
.Open "GET", url, False
.send
data = .responseText
End With
Set JSON = JsonConverter.ParseJson(data)
Set colObj = JSON("credits")
For Each c1 In colObj("cast")
Debug.Print c1
Next
Debug.Print "Director:"
Set colobj2 = colObj("director")
For Each c1 In colobj2
Debug.Print c1("displayname")
Next
End Sub
I've been able to extract the names of the four director fields, but I simply cannot access their values. What's the trick?
Try this
Sub getHTTP()
Dim Url As String, data As String
Dim xml As Object, JSON As Object, colObj, item
Url = "https://www.tiff.net/data/films/a-star-is-born.json"
Set xml = CreateObject("MSXML2.ServerXMLHTTP")
With xml
.Open "GET", Url, False
.send
data = .responseText
End With
Set JSON = JsonConverter.ParseJson(data)
Set colObj = JSON("credits")("director")
For Each item In colObj
For j = 0 To item.Count - 1
Debug.Print item.Items()(j)
Next
Next
End Sub
Print
Note: Item is dictionary object so used Debug.Print item.Items()(j) to retrieve key values.

Extract JSON in Excel VBA

I want to parse stock quotes from the Robin Hood API via Excel VBA.
Say I want Amazon, which is https://api.robinhood.com/quotes/?symbols=AMZN.
Which produces:
{
"results":[
{
"ask_price":"1592.3900",
"ask_size":100,
"bid_price":"1591.0000",
"bid_size":500,
"last_trade_price":"1592.3900",
"last_extended_hours_trade_price":"1592.0000",
"previous_close":"1600.1400",
"adjusted_previous_close":"1600.1400",
"previous_close_date":"2018-05-07",
"symbol":"AMZN",
"trading_halted":false,
"has_traded":true,
"last_trade_price_source":"consolidated",
"updated_at":"2018-05-08T23:58:44Z",
"instrument":"https://api.robinhood.com/instruments/c0bb3aec-bd1e-471e-a4f0-ca011cbec711/"
}
]
}
Using an example like this answer, I have installed VBA-JSON and turned on Microsoft Scripting Runtime.
My code:
Public Sub STOCKQUOTE()
Dim http As Object
Set http = CreateObject("MSXML2.XMLHTTP")
Const sURL As String = "https://api.robinhood.com/quotes/?symbols=AMZN"
http.Open "GET", sURL, False
http.send
Dim jsonResponse As Dictionary
Set jsonResponse = JsonConverter.ParseJson(http.responseText)
Dim results As String
Set results = jsonResponse("results")
MsgBox results
End Sub
But this doesn't work, instead I get Compiler Error: Object Required for the line Set results = jsonResponse("results").
If I add Debug.Print http.responseText I see the correct JSON, but any idea what I'm doing wrong?
VBA-JSON is installed correctly, because if I use their example, it works fine:
Dim Json As Object
Set Json = JsonConverter.ParseJson("{""a"":123,""b"":[1,2,3,4],""c"":{""d"":456}}")
But if I try changing Dictionary to Object, I get Run-time error '450': Wrong number of arguments or invalid property assignment.
Your json has an object called results. There could be, but isn't, multiple result objects. You have only one, so I think it's leading to confusion. Each result is going to get it's own entry in your jsonResponse dictionary. The ITEM in that dictionary will, itself, be a dictionary.
The best way to deal with iterating through the dictionary in a dictionary is to declare a new dictionary, I'm calling att for "Attributes" and then fill that dictionary with each iteration through the jsonResponse dictionary. It will only iterate once though as you only have one result:
Public Sub STOCKQUOTE()
Dim http As Object
Set http = CreateObject("MSXML2.XMLHTTP")
Const sURL As String = "https://api.robinhood.com/quotes/?symbols=AMZN"
http.Open "GET", sURL, False
http.send
Dim jsonResponse As Dictionary
Set jsonResponse = JsonConverter.ParseJson(http.responseText)
Dim att As Dictionary
For Each att In jsonResponse("results")
Debug.Print att("last_trade_price")
Next att
End Sub
Alternatively, because you have only a single result, you could just refer to that result by it's index in the jsonResponse dictionary and then it's attribute you are after. This makes the code smaller, but if you ever get more than one result from your REST query it will be lost forever. No biggie though since you don't expect that to happen:
Public Sub STOCKQUOTE()
Dim http As Object
Set http = CreateObject("MSXML2.XMLHTTP")
Const sURL As String = "https://api.robinhood.com/quotes/?symbols=AMZN"
http.Open "GET", sURL, False
http.send
Dim jsonResponse As Dictionary
Set jsonResponse = JsonConverter.ParseJson(http.responseText)
MsgBox (jsonResponse("results")(1)("last_trade_price"))
End Sub

VBA access to a json property without name property

I'm trying to access in VBA to over 508 "tank_id"s from a JSON file as you can see here.
I'm using cStringBuilder, cJSONScript and JSONConverter to parse the JSON file.
My main issue is that I can't pass threw all those ids because I don't know how to get the "1" "33" "49" "81" that are without names.
Here si the code I tried to get them, without success.
Const myurl2 As String = "https://api.worldoftanks.eu/wot/encyclopedia/vehicles/?application_id=demo&fields=tank_id"
Sub List_id_vehicules()
Dim strRequest
Dim xmlHttp: Set xmlHttp = CreateObject("msxml2.xmlhttp")
Dim response As Object
Dim rows As Integer
Dim counter As Integer
Dim j As String
Dim k As Integer: k = 2
Dim url As String
url = myurl2
xmlHttp.Open "GET", url, False
xmlHttp.setRequestHeader "Content-Type", "text/xml"
xmlHttp.send
While Not xmlHttp.Status = 200 '<---------- wait
Wend
Set response = ParseJson(xmlHttp.ResponseText)
rows = response("meta")("count")
For counter = 1 To rows
j = counter
Dim yop As String
yop = "data[" & j & "][" & j & "]"
Sheets(2).Cells(1 + counter, 1).Value = response('data[counter]')['tank_id']
Next counter
END Sub
Could someone help me ?
The JSONConverter essentially parses the JSON text string into a set of nested Dictionary objects. So when the ParseJson function returns an Object, it's really a Dictionary. Then, when you access response("meta"), the "meta" part is the Key to the Dictionary object. It's the same thing as you nest down through the JSON.
So when you try to access response("data")("3137"), you're accessing the Dictionary returned by response("data") with the key="3137". Now the trick becomes how to get all the Keys from the response("data") object.
Here's a sample bit of code to illustrate how you can list all the tank IDs in the JSON data section:
Option Explicit
Sub ListVehicleIDs()
Const jsonFilename As String = "C:\Temp\tanks.json"
Dim fileHandle As Integer
Dim jsonString As String
fileHandle = FreeFile
Open jsonFilename For Input As #fileHandle
jsonString = Input$(LOF(fileHandle), #fileHandle)
Close #fileHandle
Dim jsonObj As Object
Set jsonObj = ParseJson(jsonString)
Dim tankCount As Long
tankCount = jsonObj("meta")("count")
Dim tankIDs As Dictionary
Set tankIDs = jsonObj("data")
Dim tankID As Variant
For Each tankID In tankIDs.keys
Debug.Print "Tank ID = " & tankID
Next tankID
End Sub