I'm trying to receive JSON through a get request over MSXML2.ServerXMLHTTP and then to parse that into a VBS dictionary.
I'm able to receive the response in what looks like the proper JSON format. However I am met with an error When I use this VbsJson class's decode method on the responseText of my request.
Cannot convert variant type of (Dispatch) to Olestr
I'm an absolute newcomer to vbs and would like a simple way to get this data into a dictionary (better if I can also define the fields that I want to extract).
The code:
Sub Search(Sender)
Dim Resp, Data
Dim UrlToGet2
UrlToGet2 = http://www.mywebsite.com/json
Set Data = CreateObject("Scripting.Dictionary")
Dim xHttp: Set xHttp = createobject("MSXML2.ServerXMLHTTP")
xHttp.Open "GET", UrlToGet2, False
xHttp.setRequestHeader "Content-Type", "application/json"
xHttp.Send
If xHttp.Status <> 200 Then
Set Resp = CreateObject("Scripting.Dictionary")
Resp.Add "success", "false"
Resp.Add "error", "HTTP Error: " & xHttp.Status & " " & xHttp.StatusText
Exit Sub
End If
Set Resp = CreateObject("Scripting.Dictionary")
Dim x, json
Set json = New VbsJson
Set x = json.Decode(xHttp.responseText)
With Resp
Dim a: a = x.Keys
Dim i
For i = 0 To x.Count -1
.Add a(i), x(a(i))
Next
End With
Set xHttp = Nothing
End Sub
Related
Consider this JSON object:
{
"fileName": "Batch_01032023_SakerItemData.xlsx",
"fileLocation": "C:\\Temp",
"message": "There are 3 errors. Please correct and try again.",
"error": [
"{Item} failed validation:Item is required.:8",
"{Type} failed validation:Type is required.:8",
"{Class} failed validation:Class is required.:8"
]
}
I am using the JsonConverter from this repo https://github.com/VBA-tools/VBA-JSON
Consider this VBA code:
Dim jsonObject As Object, item As Object
Dim objHTTP As Object
Dim url As String
Dim result As String
Dim async As Boolean
Dim body As String
body = "{""fileLocation"":""{fileLocation}""}"
body = Replace(body, "{fileLocation}", Replace(fileLocation, "\", "\\"))
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
With objHTTP
.Open "POST", url, async
.SetRequestHeader "Content-Type", "application/json"
.SetRequestHeader "Accept", "application/json"
.SetRequestHeader "Authorization", "Basic " + _
Base64Encode(authUser + ":" + authPassword)
.Send body
.waitForResponse
result = .responseText
End With
Set jsonObject = ParseJson(result)
*** What is the syntax here to loop through error object? ****
For Each item In jsonObject("error")(1)
Next
this line Set jsonObject = ParseJson(result) does not throw an error and seems to work, yet when I get to the 'for each' loop, I get Error # 424 'Object Required'.
My question is this: How can I loop through the 'error' array in the 'jsonObject' so that I can display the validation errors to the user? The error array is dynamic.
The key error returns a Collection, so first assign it to a variable declared as Collection...
Dim col As VBA.Collection
Set col = jsonObject("error")
Then loop through each item in the collection...
Dim itm As Variant
For Each itm In col
Debug.Print itm
Next itm
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
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"
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
I am trying to build Excel page from iTunes query data.
An example for Angry Birds app my query would look like:
https://itunes.apple.com/lookup?id=343200656&country=AL checking Albania iTunes
https://itunes.apple.com/lookup?id=343200656&country=DZ checking Algeria iTunes
... 150 more stores
My question is the most efficient way to do this query and parse response.
I only know how to to xmlhttp query. Please enlighten me as the better way to do this.
I have read some documentation for VB-JSON, Json.net, CDataSet, fastJSON, but cannot figure out how to get started trying those tools. Anyone have more VBA code examples pulling JSON or way to explain usage of these frameworks to a newb?
Dim innerHTML As Object
Dim myText As String
JsonCheck = ""
Set innerHTML = CreateObject("Microsoft.XMLHTTP")
With innerHTML
.Open "GET", iTunesAPI_link, False
.send
myText = .responsetext
End With
Set innerHTML = Nothing
If InStr(myText, ":0") = 20 Then 'no results found
result = "Down"
ElseIf InStr(myText, "Your request produced an error.") = 46 Then 'link error
result = HTMLCheck(human iTunes link)
Else 'found the app
result = call function which parses myText for desired fields
Endif
Here's a basic approach using the scriptcontrol:
Sub Tester()
Dim json As String
Dim sc As Object
Dim o
Set sc = CreateObject("scriptcontrol")
sc.Language = "JScript"
json = HttpGet("https://itunes.apple.com/lookup?id=343200656&country=AL")
'some json property names may be keywords in VBA, so replace with
' something similar....
json = Replace(json, """description""", """description_r""")
Debug.Print json
sc.Eval "var obj=(" & json & ")" 'evaluate the json response
'add some accessor functions
sc.AddCode "function getResultCount(){return obj.resultCount;}"
sc.AddCode "function getResult(i){return obj.results[i];}"
Debug.Print sc.Run("getResultCount")
Set o = sc.Run("getResult", 0)
Debug.Print o.kind, o.features, o.description_r
End Sub
Function HttpGet(url As String) As String
Dim oHTML As Object
Set oHTML = CreateObject("Microsoft.XMLHTTP")
With oHTML
.Open "GET", url, False
.send
HttpGet = .responsetext
End With
End Function
There's a worked-out approach in Codo's answer to this question: Excel VBA: Parsed JSON Object Loop
I had a similar issue with querying Salesforce's REST API and found dealing with JSON through ScriptControl ended up being unmanageable. I used the following library for parsing and converting to JSON and it's worked perfectly for me: https://code.google.com/p/vba-json/.
Dim JSON As New JSONLib
Dim Parsed As Object
Set Parsed = JSON.parse(jsonValue)
Debug.Print Parsed("resultCount")
Debug.Print Parsed("results")(0)
Using that library, I then wrapped up some of the common functionality for making web requests that I think would help you out: https://github.com/timhall/Excel-REST
Using these libraries, your code would look something like the following:
Dim iTunesClient As New RestClient
iTunesClient.BaseUrl = "https://itunes.apple.com/"
Dim Request As New RestRequest
Request.Format = json
Request.Resource = "lookup"
Request.AddQuerystringParam "id", "343200656"
Request.AddQuerystringParam "country", "AL"
Dim Response As RestResponse
Set Response = iTunesClient.Execute(Request)
' => GET https://itunes.apple.com/lookup?id=343200656&country=AL
If Response.StatusCode = 200 Then
' Response.Data contains converted JSON Dictionary/Collection
Debug.Print "Result Count: " & Response.Data("resultCount")
Dim i As Integer
For i = LBound(Response.Data("results")) To UBound(Response.Data("results"))
Debug.Print "Result " & i & ": " & Response.Data("results")(i)
Next i
Else
Debug.Print "Error: " & Response.Content
End If