Parsing JSON (US BLS) in VBA from MS Access - json
Thank you in advance for your assistance.
I am using a JSON VB6 Parser which can be found at: VB JSON Parser
I have the following JSON response (Comes from the BLS website, specifically this link Here:
{"status":"REQUEST_SUCCEEDED","responseTime":71,"message":[],"Results":{
"series":
[{"seriesID":"WPS012","data":[{"year":"2014","period":"M11","periodName":"November","value":"153.6","footnotes":[{"code":"P","text":"Preliminary. All indexes are subject to revision four months after original publication."}]},{"year":"2014","period":"M10","periodName":"October","value":"147.4","footnotes":[{"code":"P","text":"Preliminary. All indexes are subject to revision four months after original publication."}]},{"year":"2014","period":"M09","periodName":"September","value":"146.5","footnotes":[{"code":"P","text":"Preliminary. All indexes are subject to revision four months after original publication."}]},{"year":"2014","period":"M08","periodName":"August","value":"156.9","footnotes":[{"code":"P","text":"Preliminary. All indexes are subject to revision four months after original publication."}]},{"year":"2014","period":"M07","periodName":"July","value":"156.4","footnotes":[{}]},{"year":"2014","period":"M06","periodName":"June","value":"179.6","footnotes":[{}]},{"year":"2014","period":"M05","periodName":
"May","value":"205.4","footnotes":[{}]},{"year":"2014","period":"M04","periodName":"April","value":"201.6","footnotes":[{}]},{"year":"2014","period":"M03","periodName":"March","value":"188.1","footnotes":[{}]},{"year":"2014","period":"M02","periodName":"February","value":"180.2","footnotes":[{}]},{"year":"2014","period":"M01","periodName":"January","value":"177.8","footnotes":[{}]},{"year":"2013","period":"M12","periodName":"December","value":"183.2","footnotes":[{}]},{"year":"2013","period":"M11","periodName":"November","value":"180.4","footnotes":[{}]},{"year":"2013","period":"M10","periodName":"October","value":"186.4","footnotes":[{}]},{"year":"2013","period":"M09","periodName":"September","value":"197.1","footnotes":[{}]},{"year":"2013","period":"M08","periodName":"August","value":"222.2","footnotes":[{}]},{"year":"2013","period":"M07","periodName":"July","value":"252.9","footnotes":[{}]},{"year":"2013","period":"M06","periodName":"June","value":"259.0","footnotes":[{}]},{"year":"2013","period":"M05","p
eriodName":"May","value":"263.7","footnotes":[{}]},{"year":"2013","period":"M04","periodName":"April","value":"249.3","footnotes":[{}]},{"year":"2013","period":"M03","periodName":"March","value":"268.1","footnotes":[{}]},{"year":"2013","period":"M02","periodName":"February","value":"267.1","footnotes":[{}]},{"year":"2013","period":"M01","periodName":"January","value":"279.7","footnotes":[{}]},{"year":"2012","period":"M12","periodName":"December","value":"283.2","footnotes":[{}]},{"year":"2012","period":"M11","periodName":"November","value":"280.8","footnotes":[{}]},{"year":"2012","period":"M10","periodName":"October","value":"286.7","footnotes":[{}]},{"year":"2012","period":"M09","periodName":"September","value":"285.2","footnotes":[{}]},{"year":"2012","period":"M08","periodName":"August","value":"298.9","footnotes":[{}]},{"year":"2012","period":"M07","periodName":"July","value":"275.8","footnotes":[{}]},{"year":"2012","period":"M06","periodName":"June","value":"226.9","footnotes":[{}]},{"year":"2012","perio
d":"M05","periodName":"May","value":"233.7","footnotes":[{}]},{"year":"2012","period":"M04","periodName":"April","value":"239.9","footnotes":[{}]},{"year":"2012","period":"M03","periodName":"March","value":"243.6","footnotes":[{}]},{"year":"2012","period":"M02","periodName":"February","value":"239.9","footnotes":[{}]},{"year":"2012","period":"M01","periodName":"January","value":"243.8","footnotes":[{}]}]}]
}}`
I am able to use the parser to return "status", "responseTime" and "message". Anything beyond that (the opening of the second curly bracket) I get nothing.
Below is the code I am trying to use:
Dim p As Object
Set p = JSON.parse(gbl_response)
'Print the text of a nested property '
Debug.Print p.Item("responseTime")
'Print the text of a property within an array '
Debug.Print p.Item("Results").Item("series").Item("seriesID")
The print of p.Item("responseTime") works and returns "71", however I get an "invalid call procedure or argument" error on the second print attempt.
For the life of me, I've searched around and have not found any solutions. I've tried this which seemed almost identical, but alas, I've tried to replicate the solution here and it seems to have not worked.
Thank you for you assistance!
Public Const jsonSource As String = "{" & _
"""status"": ""REQUEST_SUCCEEDED"", " & _
"""responseTime"": 71, " & _
"""message"": [ " & _
"], " & _
"""Results"": { " & _
"""series"": [ " & _
"{ " & _
"""seriesID"": ""WPS012"", " & _
"""data"": [ " & _
"{ " & _
"""year"": ""2014"", " & _
"""period"": ""M11"", " & _
"""periodName"": ""November"", " & _
"""value"": ""153.6"", " & _
"""footnotes"": [ " & _
"{ " & _
"""code"": ""P"", " & _
"""text"": ""Preliminary. All indexes are subject to revision four months after original publication."" " & _
"} " & _
"] " & _
"} " & _
"] " & _
"}]}}"
Sub JsonTest()
Dim jsonData As Scripting.Dictionary
Set jsonData = JSON.parse(jsonSource)
Dim responseTime As String
responseTime = jsonData("responseTime")
Dim results As Scripting.Dictionary
Set results = jsonData("Results")
Dim series As Collection
Set series = results("series")
Dim seriesItem As Scripting.Dictionary
For Each seriesItem In series
Dim seriesId As String
seriesId = seriesItem("seriesID")
Debug.Print 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")
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
End Sub
Related
POST error using VBA (MS Access) for API to Neto site
I have an access database which I'm using to create a json POST API to a website utilising Neto (https://developers.neto.com.au/documentation/engineers/api-documentation). I am new to APIs, but have been researching for several months and making progress in understanding how it works. I have managed to get a 200 status response from the request which would indicate the header info (including authentication is correct) but error in relation to the body (I believe). Code as per below: Dim reader As New XMLHTTP60 Dim username As String, APIkey As String Dim strJson As String strJson = "{" & _ "'Filter': {" & _ "'OrderStatus': 'Pick'," & _ "'OutputSelector': [" & _ "'OrderID'," & _ "'ShippingOption'," & _ "]," & _ "}" & _ "}" username = "xxx" APIkey = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" reader.Open "POST", "https://www.yoursite.co.nz/do/WS/NetoAPI", False reader.setRequestHeader "NETOAPI_USERNAME", username reader.setRequestHeader "NETOAPI_KEY", APIkey reader.setRequestHeader "Content-Type", "application/json" reader.setRequestHeader "Accept", "application/json" reader.setRequestHeader "NETOAPI_ACTION", "GetOrder" reader.send strJson Debug.Print reader.Status Debug.Print reader.responseText error message: {"CurrentTime":"2021-09-17 02:42:50","Ack":"Error","Messages":[{"Error":{"Message":"JSON Error","SeverityCode":"Error"},"Warning":{"Message":"Warning","SeverityCode":"Warning","Description":"'\"' expected, at character offset 1 (before \"'Filter': {'OrderSta...\")"}}]} Initially i am just trying to retrieve 2 pieces of data (OrderID and ShippingOption) for any orders with status of Pick. i have tried replacing all ' with "" as i've seen in other posts along with a few other variations but with no luck. Any help would be appreciated. Thanks
You are using single quote instead of double quotes in your JSON The value of Filter is a collection enclosed with [ ] so I believe you need to wrap Pick as well (despite there's only 1 value). You have an extra , after ShippingOption when it's the last value so remove that. Try this instead: strJSON = "{" & _ """Filter"": {" & _ """OrderStatus"": [""Pick""]," & _ """OutputSelector"": [" & _ """OrderID""," & _ """ShippingOption""" & _ "]" & _ "}" & _ "}" Above will produce the JSON below: {"Filter": {"OrderStatus": ["Pick"],"OutputSelector": ["OrderID","ShippingOption"]}}
Get value of node in MS Access using JSOn
I am using VB-JSON parser to get data from an API and saving the data in MS access table. I am not able to figure out how to access the -KLj9kXnKd-9txfyIqM8 and -KLjJoT7gXCMq_jHx2_z. I have Table structure as below, and want to save the data as shown below. |ServerID |Name |Mobile |-KLj9kXnKd-9txfyIqM8 |Adarsh |9987 |-KLjJoT7gXCMq_jHx2_z |Manas |022 JSON { "-KLj9kXnKd-9txfyIqM8": { "personmobile": "9987", "personname": "Adarsh" }, "-KLjJoT7gXCMq_jHx2_z": { "personmobile": "022", "personname": "Manas" } } VBA Public Sub GetPerson() 'I have code here which gets the json as above from api. Dim egTran As String If reader.Status = 200 Then Set db = CurrentDb Set rs = db.OpenRecordset("tblPerson", dbOpenDynaset, dbSeeChanges) egTran = "[" & reader.responseText & "]" Set coll = Json.parse(egTran) For Each contact In coll rs.AddNew rs!Name = contact.Item("personname") rs!Mobile = contact.Item("personmobile") rs!ServerID = contact.Item("??????") what do I write in ?????? rs.Update Next End If End Sub I am also open to using any other parser. The API is based on Firebase Database
I'm not familiar with VB-JSON, but obviously "??????" is not an item of contact. Thus, if I run this test function: Public Sub TestJsonText() Dim DataCollection As Collection Dim ResponseText As String ResponseText = _ "{" & _ " ""-KLj9kXnKd-9txfyIqM8"": {" & _ " ""personmobile"": ""9987""," & _ " ""personname"": ""Adarsh""" & _ " }," & _ " ""-KLjJoT7gXCMq_jHx2_z"": {" & _ " ""personmobile"": ""022""," & _ " ""personname"": ""Manas""" & _ " }" & _ "}" If ResponseText <> "" Then Set DataCollection = CollectJson(ResponseText) MsgBox "Retrieved" & Str(DataCollection.Count) & " root member(s)", vbInformation + vbOKOnly, "Web Service Success" End If Call ListFieldNames(DataCollection) Set DataCollection = Nothing End Sub using the Json modules from VBA.CVRAPI it will print: root -KLj9kXnKd-9txfy personmobile 9987 personname Adarsh -KLjJoT7gXCMq_jH personmobile 022 personname Manas From the function ListFieldNames you can pick MemberName for the field name and DataCollection(Index)(CollectionItem.Data) for the field value to add records.
Trouble parsing JSON with vba
I can get what appears to be a valid JSON string from a web query, however, I cannot set items correctly for the life of me. Need to confirm that I'm not losing my mind... 'Call for available reports Dim URLReporta As String Dim JSONa As Object Dim var As Object Set myrequesta = CreateObject("winhttp.winhttprequest.5.1") URLReporta = ("https://secure.saashr.com:443/ta/rest/v1/reports?type=Saved&company%3shortname=" & Company) myrequesta.Open "GET", URLReporta, False myrequesta.setRequestHeader "Accept", "application/json" myrequesta.setRequestHeader "Authentication", "Bearer " & Token myrequesta.setRequestHeader "Content-Type", "application/json" myrequesta.Send Set JSONa = JsonConverter.ParseJson(myrequesta.responseText) Set var = JSONa("SavedName") Debug.Print var.Count I get an error on the line Set var = JSONa("SavedName"): run-time error '424': object required myrequesta.responseText value is as follows: {"reports":[{"SavedName":"This Year","SettingId":18959322},{"SavedName":"Time Off Requests","SettingId":18960210},{"SavedName":"Calc Hours Summary","SettingId":18960209},{"SavedName":"roster","SettingId":18960211},{"SavedName":"E/D/T","SettingId":18823042},{"SavedName":"TestZDR","SettingId":18957188}]}
The structure returned by JsonConverter.ParseJson function doesn't work such way. For your particular JSON it contains 3 levels: Root-level object has only one property reports, which contains second-level array, which in turn contains 6 third-level objects, having properties SavedName and SettingId. You are trying to get third-level's object property value from root-level object. First you need to get second-level array, then loop through it's elements, containing objects, and retrieve the SavedName properties' values of that objects. Here is the example: 'Call for available reports Dim URLReporta As String Dim JSONa As Object Dim var As Object Dim rep As Variant Set myrequesta = CreateObject("winhttp.winhttprequest.5.1") URLReporta = ("https://secure.saashr.com:443/ta/rest/v1/reports?type=Saved&company%3shortname=" & Company) myrequesta.Open "GET", URLReporta, False myrequesta.setRequestHeader "Accept", "application/json" myrequesta.setRequestHeader "Authentication", "Bearer " & Token myrequesta.setRequestHeader "Content-Type", "application/json" myrequesta.Send Set JSONa = JsonConverter.ParseJson(myrequesta.responseText) ' root level object Set var = JSONa("reports") ' second level array For Each rep In var ' third level objects Debug.Print rep("SavedName") ' property "SavedName" value of current third level object Next Here is the output: If you want just to get the number of reports, then get the array and the number of elements in it: Debug.Print JSONa("reports").Count
JSON objects can be thought of as a collection of dictionaries. So you have to walk through the inner values such as SavedName to retrieve whole dictionary objects (all SavedName values) or specific string values at indexed locations (one SavedName value): Public Sub GetJSONRequest() Dim jsonStr As String jsonStr = "{" _ & " ""reports"": [{" _ & " ""SavedName"": ""This Year""," _ & " ""SettingId"": 18959322" _ & " }, {" _ & " ""SavedName"": ""Time Off Requests""," _ & " ""SettingId"": 18960210" _ & " }, {" _ & " ""SavedName"": ""Calc Hours Summary""," _ & " ""SettingId"": 18960209" _ & " }, {" _ & " ""SavedName"": ""roster""," _ & " ""SettingId"": 18960211" _ & " }, {" _ & " ""SavedName"": ""E/D/T""," _ & " ""SettingId"": 18823042" _ & " }, {" _ & " ""SavedName"": ""TestZDR""," _ & " ""SettingId"": 18957188" _ & " }]" _ & " }" Dim JSONa As Object, element As Object, e As Variant, i As Variant, var As Variant Set JSONa = ParseJson(jsonStr) ' DICTIONARY OBJECT Set element = CreateObject("Scripting.Dictionary") Set element = JSONa("reports") ' OUTER DICTIONARY For Each e In element ' INNER COLLECTION OF DICTIONARIES For Each i In e Debug.Print i & " " & e(i) Next i Next e ' STRING VALUE OF FIRST SAVEDNAME VALUE var = JSONa("reports")(1)("SavedName") Debug.Print var Set element = Nothing Set JSONa = Nothing End Sub Output SavedName This Year SettingId 18959322 SavedName Time Off Requests SettingId 18960210 SavedName Calc Hours Summary SettingId 18960209 SavedName roster SettingId 18960211 SavedName E/D/T SettingId 18823042 SavedName TestZDR SettingId 18957188 This Year
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
How to select the file whose name includes the newest date?
I am importing a CSV file into a table in MS Access. However there are many files in the folder with the same extension and the names include dates in "mm_dd_yyyy" format. Example: Lets say I have two CSV files: my_music_02_10_2013_01_58_07_PM.csv my_music_02_11_2013_03_04_07_PM.csv Both files are in the same folder, myfolder. I want to import the file whose name contains the newest date. Here is a short snippet of my code: strPath = "F:\myfolder\" strFile = Dir(strPath & "my_music" & "*.csv") How can I determine which of my "my_music*.csv" is newest?
Seems to me the key is to extract the Date/Time from each file name so that you may compare those to find which of them is newest. Here is an Immediate window session testing the function included below. The function returns null if it can't find a string which represents a valid date. ? DateFromFilename("my_music_02_10_2013_01_58_07_PM.csv") 2/10/2013 1:58:07 PM ? DateFromFilename("my_music_no_date_here.csv") Null Public Function DateFromFilename(ByVal pFileName As String) As Variant Dim strBaseName As String Dim strDate As String Dim strPieces() As String Dim varReturn As Variant varReturn = Null strBaseName = Split(pFileName, ".")(0) 'Debug.Print "strBaseName: " & strBaseName strPieces = Split(strBaseName, "_") If UBound(strPieces) = 8 Then strDate = strPieces(4) & "-" & strPieces(2) & _ "-" & strPieces(3) & " " & strPieces(5) & ":" & _ strPieces(6) & ":" & strPieces(7) & " " & strPieces(8) End If 'Debug.Print "strDate: " & strDate If IsDate(strDate) Then varReturn = CDate(strDate) End If DateFromFilename = varReturn End Function