VBA JSON - Parse Multiple Values - json

I'm having trouble using the JSON-VBA converter with a multiple values key.
I have the normal recursion routines written to navigate JSON trees but here's an example of a simple JSON parse which I can't seem to get to work.
See this for the VBA-JSON converter software, which is terrific and fast.
Environment: Windows 7 / Access 2016 / Private LAN (no Internet)
Here's the code:
Option Compare Database
Option Explicit
Sub testparse()
Dim js As String, i As Long, jo As Object, item As Variant
Dim keys(), vals()
' fails on this string
js = "{ !Category!: !Famous Pets!," & _
"!code!: [!a!,!b!,!c!] }" ' string with multiple values
' with the following string, this works
js = "{ !Category!: !Famous Pets!," & _
" !code!: !singlecodevalue! }"
js = Replace(js, "!", Chr(34)) ' replace ! with quotes
Debug.Print " js = " & js
Set jo = JsonConverter.ParseJson(js) ' returns object with json elements
i = 0
ReDim keys(1 To jo.Count)
ReDim vals(1 To jo.Count)
Debug.Print " Number keys found at top level " & jo.Count
For Each item In jo
i = i + 1
keys(i) = item
vals(i) = jo(item)
Next item
For i = 1 To jo.Count
Debug.Print "key " & keys(i) & " = " & vals(i)
Next i
End Sub

For each item you encounter when running through a JSON object, you have to determine what you're dealing with -- especially if you don't know ahead of time how many items in an array! It gets even trickier if you have a compound JSON structure with collections inside arrays and such.
The bottom line is that you have to check each item you pull out of the JSON object and figure out what it is before accessing it. The top level of a JSON object (assuming the use of JsonConverter) will always be a Dictionary. So you can count on looping through the keys of the top level dictionary:
Dim json As Dictionary
Set json = JsonConverter.ParseJson(someJsonString)
Dim topLevelKey As String
For Each topLevelKey In json
Dim item As Variant
Debug.Print topLevelKey & " = " & item
Next topLevelKey
The problem with this is the item is not always a simple string. It can be a value (String), an array (Collection), or a group (Dictionary). See this answer as a good reference.
Basically, this means you have to check each item before you use it. So you can check it like this:
Select Case TypeName(item)
Case "Collection"
'--- loop through the item as a Collection
Case "Dictionary"
'--- loop through the item as a Dictionary
Case Else
'--- the item is a value of some type (String, Boolean, etc)
End Select
In my example here, I created a sub called ParseItem that checks each of the items in this manner. Reworking your original code into the example below:
Option Explicit
Sub testparse()
Dim js As String, i As Long, jo As Object, item As Variant
Dim keys(), vals()
' fails on this string
js = "{ !Category!: !Famous Pets!," & _
"!code!: [!a!,!b!,!c!] }" ' string with multiple values
' with the following string, this works
' js = "{ !Category!: !Famous Pets!," & _
' " !code!: !singlecodevalue! }"
'--- compound example
' js = "{ !Category!: !Famous Pets!,!code!: [!a!,!b!,{!c! : { !c1! : !1!, !c2!:!2!}}] }"
js = Replace(js, "!", Chr(34)) ' replace ! with quotes
Debug.Print "----------------------"
Debug.Print "js = " & js
Set jo = JsonConverter.ParseJson(js) ' returns object with json elements
ParseDictionary 1, "root", jo
End Sub
Private Sub ParseCollection(ByVal level As Long, _
ByVal key As String, _
ByRef jsonCollection As Variant)
Dim item As Variant
For Each item In jsonCollection
ParseItem level, key, item
Next item
End Sub
Private Sub ParseDictionary(ByVal level As Long, _
ByVal key As String, _
ByRef jsonDictionary As Variant)
Dim dictKey As Variant
For Each dictKey In jsonDictionary
ParseItem level, dictKey, jsonDictionary(dictKey)
Next dictKey
End Sub
Private Sub ParseItem(ByVal level As Long, _
ByVal key As String, _
ByRef item As Variant)
Select Case TypeName(item)
Case "Collection"
Debug.Print Format(level + 1, "00 ") & key & " (collection)"
ParseCollection (level + 1), key, item
Case "Dictionary"
Debug.Print Format(level + 1, "00 ") & key & " (dictionary)"
ParseDictionary (level + 1), key, item
Case Else
Debug.Print Format(level, "00 ") & key & " = " & item
End Select
End Sub

Related

Parse JSON with VBA (Access 2010) subscript out of range error

I'm parsing a JSON string similar to the solution at this link: Parse JSON with VBA (Access 2010). However, I'm getting the "subscript out of range" error.
Public Sub GetValues()
Dim s As String, rates(), i As Long
s = "{""id"":""14acfa60-c0e1-47fb-8f80-ca0831bf3b52"",""class"":""us_equity"",""exchange"":""ARCA"",""symbol"":""UVXY"",""name"":"""",""status"":""active"",""tradable"":true,""marginable"":true,""shortable"":false,""easy_to_borrow"":false}"
rates = Array("id", "class", "exchange", "symbol", "name", "status", "tradeable", "marginable", "shortable", "easy_to_borrow")
For i = LBound(rates) To UBound(rates)
Debug.Print rates(i) & ":" & GetRate(s, rates(i))
Next i
End Sub
Public Function GetRate(ByVal s As String, ByVal delimiter As String) As String
GetRate = Replace(Split(Split(s, delimiter & Chr$(34) & Chr$(58))(1), Chr$(44))(0), Chr$(125), vbNullString)
End Function
You have a typo in your code:
Public Sub GetValues()
Dim s As String, rates(), i As Long
'Just for better reading.
's = "{""id"":""14acfa60-c0e1-47fb-8f80-ca0831bf3b52"", _
""class"":""us_equity"", _
""exchange"":""ARCA"", _
""symbol"":""UVXY"", _
""name"":"""", _
""status"":""active"", _
""tradable"":true, _
""marginable"":true, _
""shortable"":false, _
""easy_to_borrow"":false}"
'""tradable"":true, _ <<<<< ERROR in s var. In your rate array you say: "tradeable"
' "tradeable", _ <<<<< rate Array! (I just change it to run the code)
s = "{""id"":""14acfa60-c0e1-47fb-8f80-ca0831bf3b52"",""class"":""us_equity"",""exchange"":""ARCA"",""symbol"":""UVXY"",""name"":"""",""status"":""active"",""tradable"":true,""marginable"":true,""shortable"":false,""easy_to_borrow"":false}"
rates = Array("id", _
"class", _
"exchange", _
"symbol", _
"name", _
"status", _
"tradable", _
"marginable", _
"shortable", _
"easy_to_borrow")
For i = LBound(rates) To UBound(rates)
Debug.Print rates(i) & ":" & GetRate(s, rates(i))
Next i
End Sub
Public Function GetRate(ByVal s As String, ByVal delimiter As String) As String
'Chr$(34) = "
'Chr$(58) = :
'Chr$(125) = }
'Again... better reading.
Dim A: A = Split(s, delimiter & Chr$(34) & Chr$(58))(1)
Dim B: B = Split(A, Chr$(44))(0)
Dim C: C = Chr$(125)
GetRate = Replace(B, C, vbNullString)
End Function
First of all the issue in your code is that you have a typo: In your JSON you have tradable but your rate is called tradeable.
I recommend to include a proper error handling in your function. So if something gets wrong there you don't get stuck but a error message instead.
I also recommend not to have everything in one line in your function like Replace(Split(Split(… because if something gets wrong you don't know in which part it went wrong: First or second Split or the Replace. So if you do that in multiple lines (see below) then you can return a more useful error message.
Shorter code is not necessarily faster and better. But code that is easily readable, debugable and maintainable is very good code because you will make less errors and find them quicker.
I highly recommend to use meaningful variable names. Names like s for example are very bad names. If you use Json instead you always immediately see that this variable contains your JSON string.
Meaningful variables make your code better because it is more human readable and VBA doesn't care about the extra 3 characters.
Finally I would declare variables as close as possible to their first use.
So the code below is a bit longer but has much more improved readability and an error handling that gives at least a proper info if the key word you were looking for did not exist in your JSON.
Option Explicit
Public Sub GetValues()
Dim Json As String
Json = "{""id"":""14acfa60-c0e1-47fb-8f80-ca0831bf3b52"",""class"":""us_equity"",""exchange"":""ARCA"",""symbol"":""UVXY"",""name"":"""",""status"":""active"",""tradable"":true,""marginable"":true,""shortable"":false,""easy_to_borrow"":false}"
Dim Rates() As Variant
Rates = Array("id", "tradeable", "class", "exchange", "symbol", "name", "status", "tradeable", "marginable", "shortable", "easy_to_borrow")
Dim i As Long
For i = LBound(Rates) To UBound(Rates)
Debug.Print Rates(i) & ":" & GetRate(Json, Rates(i))
Next i
End Sub
Public Function GetRate(ByVal Key As String, ByVal Delimiter As String) As String
On Error GoTo RETURN_ERR
Dim SplitKey() As String
SplitKey = Split(Key, Delimiter & Chr$(34) & Chr$(58))
If UBound(SplitKey) = 0 Then
GetRate = "KEY NOT FOUND"
Exit Function
End If
Dim ValueOfKey As String
ValueOfKey = Split(SplitKey(1), Chr$(44))(0)
'remove } from value
ValueOfKey = Replace(ValueOfKey, Chr$(125), vbNullString)
'return
GetRate = ValueOfKey
Exit Function
RETURN_ERR:
GetRate = "Unknown error while extracting value. Check the JSON syntax."
End Function

Loop through the JSON object keys in excel vba

I am trying to learn about JSON in excel vba so bear me ..
This is JSON sample ..
{"Title":"Close-Up","Year":"1990","Rated":"NOT RATED","Released":"30 Oct 1991","Runtime":"98 min","Genre":"Documentary, Biography, Crime","Director":"Abbas Kiarostami","Writer":"Abbas Kiarostami","Actors":"Hossain Sabzian, Mohsen Makhmalbaf, Abolfazl Ahankhah, Mehrdad Ahankhah","Plot":"The true story of Hossain Sabzian that impersonated the director Mohsen Makhmalbaf to convince a family they would star in his so-called new film.","Language":"Persian, Azerbaijani","Country":"Iran","Awards":"2 wins.","Poster":"https://m.media-amazon.com/images/M/MV5BMzE4Mjc0MjI1N15BMl5BanBnXkFtZTcwNjI3MzEzMw##._V1_SX300.jpg","Ratings":[{"Source":"Internet Movie Database","Value":"8.3/10"},{"Source":"Rotten Tomatoes","Value":"88%"}],"Metascore":"N/A","imdbRating":"8.3","imdbVotes":"11,546","imdbID":"tt0100234","Type":"movie","DVD":"19 Feb 2002","BoxOffice":"N/A","Production":"Zeitgeist Films","Website":"http://www.zeitgeistfilm.com/current/closeup/closeup.html","Response":"True"}
This is in range("A1")
and I used this code to loop through each key and debug the key and its related value
Sub Test()
Dim ws As Worksheet
Dim jsonObject As Object
Dim item As Variant
Dim jsonText As String
Set ws = ThisWorkbook.Worksheets("Sheet1")
jsonText = ws.Cells(1, 1).Value
Set jsonObject = JsonConverter.ParseJson(jsonText)
For Each item In jsonObject.Keys
Debug.Print item & vbTab & jsonObject(item)
Next item
End Sub
The code works well in regular combinations of key and value but encountered an error at the key 'Ratings' as it is not as the others
How can I print the value of this key without nested loops. I mean to print this output
[{"Source":"Internet Movie Database","Value":"8.3/10"},{"Source":"Rotten Tomatoes","Value":"88%"}]
Thanks advanced for help
Sounds like you might want to stringify the values :
For Each item In jsonObject.Keys
Debug.Print item, Replace(JsonConverter.ConvertToJson(jsonObject(item)), """", "")
Next item
I would probably use a recursive sub to empty all the dictionaries including those inside the collection. It does have a level of nesting but it is minimal.
Public Sub GetInfoFromSheet()
Dim jsonStr As String, json As Object
jsonStr = [A1]
Set json = JsonConverter.ParseJson(jsonStr)
emptyDict json
End Sub
Public Sub emptyDict(ByVal json As Object)
Dim key As Variant, item As Object
For Each key In json
Select Case TypeName(json(key))
Case "String"
Debug.Print key & vbTab & json(key)
Case "Collection"
For Each item In json(key)
emptyDict item
Next
End Select
Next
End Sub
Examining your JSON structure:
You have an initial dictionary, denoted by {}, then within this a series of key and values pairs and a collection, denoted by []. That collection is made up also of dictionaries. So, I use a test with TypeName to determine if the top level dictionary value is String or Collection. If it is a Collection I recursively call the emptyDict sub to write out the results of the inner dictionaries.
To generate the string shown you only need what is in the collection:
Option Explicit
'[{"Source":"Internet Movie Database","Value":"8.3/10"},{"Source":"Rotten Tomatoes","Value":"88%"}]
Public Sub GetInfoFromSheet()
Dim jsonStr As String, json As Object, item As Object, output As String, key As Variant
jsonStr = [A1]
Set json = JsonConverter.ParseJson(jsonStr)("Ratings")
For Each item In json
For Each key In item.keys
If key = "Value" Then
output = output & "," & Chr$(34) & key & Chr$(34) & ":" & Chr$(34) & item(key) & Chr$(34) & "}"
Else
output = output & ",{" & Chr$(34) & key & Chr$(34) & ":" & Chr$(34) & item(key) & Chr$(34)
End If
Next key
Next
output = "[" & Replace$(output, ",", vbNullString, , 1) & "]"
Debug.Print output
End Sub

Using VBA and VBA-JSON to access JSON data from Wordpress API

I'm building a VBA app that creates and modifies Wordpress website pages using resources scraped from the web. The Wordpress API returns a JSON file but there is no native support for parsing JSON in VBA so I imported VBA-JSON from GitHub. Here is the subroutine:
Sub Wordpress()
'
' Wordpress API Test
'
Dim wpResp As Variant
Dim sourceSheet As String
Dim resourceURL As String
sourceSheet = "Resources"
resourceURL = Sheets(sourceSheet).Cells(6, 1)
wpResp = getJSON(resourceURL + "/wp-json/wp/v2/posts")
End Sub
And the function it calls.
Function getJSON(link) As Object
Dim response As String
Dim json As Object
On Error GoTo recovery
Dim retryCount As Integer
retryCount = 0
Dim web As MSXML2.XMLHTTP60
Set web = New MSXML2.XMLHTTP60
the_start:
web.Open "GET", link, False, UserName, pw
web.setRequestHeader "Content-type", "application/json"
web.send
response = web.responseText
While web.readyState <> 4
DoEvents
Wend
On Error GoTo 0
Debug.Print link
Debug.Print web.Status; "XMLHTTP status "; web.statusText; " at "; Time
Set json = JsonConverter.ParseJson(response)
'getJSON = json ' this line produces Object variable or With block variable not set error but I can deal with it later
Exit Function
recovery:
retryCount = retryCount + 1
Debug.Print "Error number: " & Err.Number & " " & Err.Description & " Retry " & retryCount
Application.StatusBar = "Error number: " & Err.Number & " " & Err.Description & " Retry " & retryCount
If retryCount < 4 Then GoTo the_start Else Exit Function
End Function
This code returns an Object/Collection with 1 item that contains a Variant/Object/Dictionary with 24 items but I'm lost on how to access these items. Here is a screenshot:
If I use the immediate window to query ?json.count I get the correct result "1" but after about six hours of researching on the web and trying as many variants as I could find, I'm still stuck on how to access the other 24.
Here is the JSON:
[{"id":1,"date":"2018-06-22T18:13:00","date_gmt":"2018-06-22T22:13:00","guid":{"rendered":"http:\/\/mytestsite.org\/?p=1"},"modified":"2018-06-22T18:13:00","modified_gmt":"2018-06-22T22:13:00","slug":"hello-world","status":"publish","type":"post","link":"http:\/\/mytestsite.org\/hello-world\/","title":{"rendered":"Blog Post Title"},"content":{"rendered":"<p>What goes into a blog post? Helpful, industry-specific content that: 1) gives readers a useful takeaway, and 2) shows you’re an industry expert. <\/p>\n<p>Use your company’s blog posts to opine on current industry topics, humanize your company, and show how your products and services can help people.<\/p>\n","protected":false},"excerpt":{"rendered":"<p>What goes into a blog post? Helpful, industry-specific content that: 1) gives readers a useful takeaway, and 2) shows you’re…<\/p>\n","protected":false},"author":1,"featured_media":212,"comment_status":"open","ping_status":"open","sticky":false,"template":"","format":"standard","meta":[],"categories":[1],"tags":[],"_links":{"self":[{"href":"http:\/\/mytestsite.org\/wp-json\/wp\/v2\/posts\/1"}],"collection":[{"href":"http:\/\/mytestsite.org\/wp-json\/wp\/v2\/posts"}],"about":[{"href":"http:\/\/mytestsite.org\/wp-json\/wp\/v2\/types\/post"}],"author":[{"embeddable":true,"href":"http:\/\/mytestsite.org\/wp-json\/wp\/v2\/users\/1"}],"replies":[{"embeddable":true,"href":"http:\/\/mytestsite.org\/wp-json\/wp\/v2\/comments?post=1"}],"version-history":[{"href":"http:\/\/mytestsite.org\/wp-json\/wp\/v2\/posts\/1\/revisions"}],"wp:featuredmedia":[{"embeddable":true,"href":"http:\/\/mytestsite.org\/wp-json\/wp\/v2\/media\/212"}],"wp:attachment":[{"href":"http:\/\/mytestsite.org\/wp-json\/wp\/v2\/media?parent=1"}],"wp:term":[{"taxonomy":"category","embeddable":true,"href":"http:\/\/mytestsite.org\/wp-json\/wp\/v2\/categories?post=1"},{"taxonomy":"post_tag","embeddable":true,"href":"http:\/\/mytestsite.org\/wp-json\/wp\/v2\/tags?post=1"}],"curies":[{"name":"wp","href":"https:\/\/api.w.org\/{rel}","templated":true}]}}]
At the end of the day, I want to be able to spin up a few hundred pages of WP content extracted and collated from several internet sources and keep them up to date using this app. Further suggestions beyond the problem here would also be useful so long as we don't get outside of VBA.
The JsonConverter is returning a collection of VBA.Collections Scripting.Dictionaries, and Values. In order to understand the output you will have to test the TypeName of all the returned values.
The real question is "How to navigate through a json object (or any unknown object for that matter) and access the values within.
Immediate Window
Using the Immediate Window and the json object from the OP's post I will try to describe the thought process (in the style of the must read book: The Little Schemer)
' What is json?
?TypeName(JSON)
Collection
'json is a collection
'How big is JSON
?JSON.Count
1
'JSON is a collection of 1 Item
'What is Type that Item?
?TypeName(JSON(1))
Dictionary
'JSON(1) is a Dictionary
'What is the first key in the JSON(1) Dictionary?
?JSON(1).Keys()(0)
id
'The first key in the JSON(1) Dictionary is "id"
'What is the Type of the value of "id"?
?TypeName(JSON(1)("id"))
Double
'JSON(1)("id") is a number
'What is its value
?JSON(1)("id")
1
Of course this process can get tedious consider the amount of nesting in this JSON Object.
JSON(1)("_links")("curies")(1)("templated")
Collection|Dictionary|Dictionary|Collection|Boolean Value
So I guess the best thing to do is write a function that will print all the accessor to the Immediate Window and go from there.
PrintJSONAccessors:Sub
Sub PrintJSONAccessors(JSON As Variant, Optional Prefix As String)
Dim data As Variant, Key As Variant, Value As Variant
Dim Accessor As String, ArrayAccessor As String
Dim n As Long
If TypeName(JSON) = "Collection" Then
For n = 1 To JSON.Count
Accessor = Prefix & "(" & n & ")"
If TypeName(JSON(n)) = "Dictionary" Or TypeName(JSON(n)) = "Collection" Then
PrintJSONAccessors JSON(n), Accessor
Else
Debug.Print Accessor
End If
Next
Else
For Each Key In JSON
If TypeName(Key) = "Dictionary" Or TypeName(Key) = "Collection" Then
PrintJSONAccessors Key, Prefix
ElseIf TypeName(JSON(Key)) = "Dictionary" Or TypeName(JSON(Key)) = "Collection" Then
Accessor = Prefix & "(" & Chr(34) & Key & Chr(34) & ")"
PrintJSONAccessors JSON(Key), Accessor
ElseIf TypeName(JSON(Key)) = "Dictionary" Then
Accessor = Prefix & "(" & Chr(34) & Key & Chr(34) & ")"
PrintJSONAccessors JSON(Key), Accessor
ElseIf TypeName(JSON(Key)) = "Variant()" Then
data = JSON(Key)
For n = LBound(data) To UBound(data)
Accessor = Prefix & "(" & Chr(34) & Key & Chr(34) & ")"
ArrayAccessor = Prefix & "(" & Chr(34) & Key & Chr(34) & ")" & "(" & n & ")"
If TypeName(data(n)) = "Dictionary" Then
PrintJSONAccessors data(n), ArrayAccessor
Else
Debug.Print ArrayAccessor
End If
Next
Else
Accessor = Prefix & "(" & Chr(34) & Key & Chr(34) & ")"
Debug.Print Accessor
End If
Next
End If
End Sub
Usage:
PrintJSONAccessors JSON, "?JSON"
It appears that the MSScriptControl.ScriptControl only works on 32 bit systems. I guess that is what SIM was alluding to in his comments. Although, my answer is IMO correct, you should ignore the next section of comments.
FYI: I posted a function that parses the JSON into Arrays and Dictionaries Function to Return a JSON Like Objects Using VBA Collections and Arrays on Code Review. It is not a replacement for JsonConverter or omegastripes's JSON.Bas. It demonstrates that you can add JScript code to CreateObject("MSScriptControl.ScriptControl") and use it to process the JSON.
Try the code:
Set json = JsonConverter.ParseJson(s)
For Each k In json(1)
Debug.Print k & vbTab & json(1)(k)
Next
UPDATE
Take a look at the below example. Import JSON.bas module into the VBA project for JSON processing.
Option Explicit
Sub Test()
Dim sJSONString As String
Dim vJSON
Dim sState As String
Dim aData()
Dim aHeader()
Dim vResult
' Read JSON sample from file C:\Test\sample.json
sJSONString = ReadTextFile("C:\Test\sample.json", 0)
' Parse JSON sample
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then
MsgBox "Invalid JSON"
End
End If
' Get the 1st element from root [] array
Set vJSON = vJSON(0)
' Convert raw JSON to 2d array and output to worksheet #1
JSON.ToArray vJSON, aData, aHeader
With Sheets(1)
.Cells.Delete
.Cells.WrapText = False
OutputArray .Cells(1, 1), aHeader
Output2DArray .Cells(2, 1), aData
.Columns.AutoFit
End With
' Flatten JSON
JSON.Flatten vJSON, vResult
' Convert flattened JSON to 2d array and output to worksheet #2
JSON.ToArray vResult, aData, aHeader
With Sheets(2)
.Cells.Delete
.Cells.WrapText = False
OutputArray .Cells(1, 1), aHeader
Output2DArray .Cells(2, 1), aData
.Columns.AutoFit
End With
MsgBox "Completed"
End Sub
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Function ReadTextFile(sPath As String, lFormat As Long) As String
' lFormat -2 - System default, -1 - Unicode, 0 - ASCII
With CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath, 1, False, lFormat)
ReadTextFile = ""
If Not .AtEndOfStream Then ReadTextFile = .ReadAll
.Close
End With
End Function
BTW, the similar approach applied in other answers.

Serializing from object to JSON

I'm consuming a web service in some legacy applications written in VB6. Right now I've been able to parse the JSON returned from a web service using the VB JSON parser found here: http://www.ediy.co.nz/vbjson-json-parser-library-in-vb6-xidc55680.html
However, I'm still hardcoding the JSON string that gets passed into the POST request payload.
Generically speaking:
result = WebRequestPost(url, "{""Id"":""" & productId & """,""Name"":""" & productName & """,""Category"":""" & productCat & """,""Price"":""" & productPrice & """}")
Is there a cleaner way that I can generate a JSON payload based on an object?
I ended up building my own assembler of sorts...
Dim jsonArray() As String
'_______________________________________________________________
'Initializes the opening and closing braces of the JSON payload
Public Sub JSONInitialize()
ReDim jsonArray(1)
jsonArray(0) = "{"
jsonArray(1) = "}"
End Sub
'_______________________________________________________________
'Adds a string value to the JSON payload
Public Sub JSONAddString(nFieldName As String, nValue As String)
Dim temp As String
temp = jsonArray(UBound(jsonArray))
Dim index As Integer
index = UBound(jsonArray)
ReDim Preserve jsonArray(UBound(jsonArray) + 1)
jsonArray(UBound(jsonArray)) = temp
jsonArray(index) = """" & nFieldName & """:""" & nValue & ""","
End Sub
'_______________________________________________________________
'Adds an integer value to the JSON payload
Public Sub JSONAddInt(nFieldName As String, nValue As Integer)
Dim temp As String
temp = jsonArray(UBound(jsonArray))
Dim index As Integer
index = UBound(jsonArray)
ReDim Preserve jsonArray(UBound(jsonArray) + 1)
jsonArray(UBound(jsonArray)) = temp
jsonArray(index) = """" & nFieldName & """:" & nValue & ","
End Sub
So (sanitized) execution ends up looking like:
Dim o As New MyObject
Call o.JSONInitialize
Call o.JSONAddString("My JSON String Field", "Test String Value")
Call o.JSONAddInt("My JSON Int Field", 25)
o.JSONSerialize() returns:
{"My JSON String Field":"Test String Value","My JSON Int Field": 25,}
Unfortunately it puts the comma at the end so it won't win any beauty contests but the API I'm calling doesn't care.

Parsing JSON (US BLS) in VBA from MS Access, update

So, I had previously asked a question that was successfully answered (here: Parsing JSON (US BLS) in VBA from MS Access)
The new response I get that differs from the original question is that I've added a request to capture calculations. I've tried adding as a collection and scripting dictionary like footnotes but I see the format is not quite the same, and therefore I think it results in null when I try to gather the 1,3,6 and 12 month changes. I'd like to have some help figuring out how to capture those changes in the following response:
{
"status":"REQUEST_SUCCEEDED",
"responseTime":64,
"message":["BLS does not produce net change calculations for Series WPU381103"],
"Results":
{
"series":
[
{
"seriesID":"WPU381103",
"data":
[
{
"year":"2014",
"period":"M12",
"periodName":"December",
"value":"98.9",
"footnotes":
[
{
"code":"P",
"text":"Preliminary. All indexes are subject to revision four months after original publication."
}
],
"calculations":
{
"net_changes":{},
"pct_changes":
{
"1":"0.0",
"3":"0.1",
"6":"0.0",
"12":"-0.7"
}
}
},
{
"year":"2014",
"period":"M11",
"periodName":"November",
"value":"98.9",
"footnotes":
[
{
"code":"P",
"text":"Preliminary. All indexes are subject to revision four months after original publication."
}
],
"calculations":
{
"net_changes":{},
"pct_changes":
{
"1":"0.1",
"3":"-0.4",
"6":"0.0",
"12":"-0.7"
}
}
},...
You will notice that there is a part now that says calculations, and seperates values by net changes, and percent changes. I am trying to get the percent changes within the "1", "3", "6" and "12" data items.
Here is the current code I'm that does NOT find calculations but captures all the other data:
response = http.responseText
jsonSource = response
I = 0
Dim jsonData As Scripting.Dictionary
Set jsonData = JSON.parse(jsonSource)
Dim responseTime As String
responseTime = jsonData("responseTime")
Dim results As Scripting.Dictionary
On Error Resume Next
Set results = jsonData("Results")
Dim series As Collection
On Error Resume Next
Set series = results("series")
Dim seriesItem As Scripting.Dictionary
For Each seriesItem In series
Dim seriesId As String
seriesId = seriesItem("seriesID")
Dim Data As Collection
Set Data = seriesItem("data")
Dim dataItem As Scripting.Dictionary
For Each dataItem In Data
Dim Year As String
Year = dataItem("year")
I = 1 + I
Dim Period As String
Period = dataItem("period")
Dim periodName As String
periodName = dataItem("periodName")
Dim Value As String
Value = dataItem("value")
Dim footnotes As Collection
Set footnotes = dataItem("footnotes")
Dim footnotesItem As Scripting.Dictionary
For Each footnotesItem In footnotes
Dim Code As String
Code = footnotesItem("code")
Dim text As String
text = footnotesItem("text")
Next footnotesItem
Next dataItem
Next seriesItem
Pretty straight forward. Remember, the JSON module implements JavaScript arrays as collections and objects as Scripting.Dictionary instances.
In your context, [..].calculations, [..].calculations.net_changes and [..].calculations.pct_changes are all objects so they are all converted to Dictionary objects.
So in your code, after the For Each footnotesItem In footnotes: [..]: Next footnotesItem block (therefore, above & before the Next dataItem line), you could add the following lines:
Dim calculations As Scripting.Dictionary
Dim sIndent As String
Dim calcNetChanges As Scripting.Dictionary
Dim calcPctChanges As Scripting.Dictionary
Dim varItem As Variant
Set calculations = dataItem("calculations")
sIndent = String(4, " ")
Set calcNetChanges = calculations("net_changes")
Debug.Print Year & ", " & Period & " (" & periodName & ") - Net Changes:"
If calcNetChanges.Count > 0 Then
For Each varItem In calcNetChanges.keys
Debug.Print sIndent & CStr(varItem) & ": " & calcNetChanges.Item(varItem)
Next varItem
Else
Debug.Print sIndent & "(none)"
End If
Set calcPctChanges = calculations("pct_changes")
Debug.Print Year & ", " & Period & " (" & periodName & ") - Pct Changes:"
If calcPctChanges.Count > 0 Then
For Each varItem In calcPctChanges.keys
Debug.Print sIndent & CStr(varItem) & ": " & calcPctChanges.Item(varItem)
Next varItem
Else
Debug.Print sIndent & "(none)"
End If
which, with the json data provided, should output something like this:
2014, M12 (December) - Net Changes:
(none)
2014, M12 (December) - Pct Changes:
1: 0.0
3: 0.1
6: 0.0
12: -0.7
2014, M11 (November) - Net Changes:
(none)
2014, M11 (November) - Pct Changes:
1: 0.1
3: -0.4
6: 0.0
12: -0.7
If you want to access the items of calculations.net_changes and calculations.pct_changes directly by their keys (known in advance), you would replace the two For Each varItem blocks by, respectively:
If calcNetChanges.Exists("1") Then Debug.Print "1: " & calcNetChanges.Item("1")
If calcNetChanges.Exists("3") Then Debug.Print "3: " & calcNetChanges.Item("3")
If calcNetChanges.Exists("6") Then Debug.Print "6: " & calcNetChanges.Item("6")
If calcNetChanges.Exists("12") Then Debug.Print "12: " & calcNetChanges.Item("12")
[..]
If calcPctChanges.Exists("1") Then Debug.Print "1: " & calcPctChanges.Item("1")
If calcPctChanges.Exists("3") Then Debug.Print "3: " & calcPctChanges.Item("3")
If calcPctChanges.Exists("6") Then Debug.Print "6: " & calcPctChanges.Item("6")
If calcPctChanges.Exists("12") Then Debug.Print "12: " & calcPctChanges.Item("12")
Finally, you should note that in the json data you're giving as the example, percentages (i.e. values of items for [..].calculations.net_changes & [..].calculations.pct_changes) are provided as strings, therefore you would probably want to convert those in Double (or Single) data using Val() to perform math or other numerical operations on them, e.g.:
Dim pctChange_1 As Double, pctChange_3 As Double
Dim pctChange_6 As Double, pctChange_12 As Double
pctChange_1 = 0#
pctChange_3 = 0#
pctChange_6 = 0#
pctChange_12 = 0#
If calcPctChanges.Exists("1") Then pctChange_1 = CDbl(Val(calcPctChanges.Item("1")))
If calcPctChanges.Exists("3") Then pctChange_3 = CDbl(Val(calcPctChanges.Item("3")))
If calcPctChanges.Exists("6") Then pctChange_6 = CDbl(Val(calcPctChanges.Item("6")))
If calcPctChanges.Exists("12") Then pctChange_12 = CDbl(Val(calcPctChanges.Item("12")))
Declare calculations as a Scripting.Dictionary and its pct-changes as Scripting.Dictionary as well. Append the following code snippet after the code for footnotes. HTH
Dim calculations As Scripting.Dictionary
Set calculations = dataItem("calculations")
Dim pct_changes As Scripting.Dictionary
Set pct_changes = calculations("pct_changes")
Dim pct_change As Variant
For Each pct_change In pct_changes
Debug.Print pct_change & ":" & pct_changes(pct_change)
Next pct_change
The Debug.Print pct_change & ":" & pct_changes(pct_change) produces the following result for the first calculations set:
1:0.0
3:0.1
6:0.0
12:-0.7