Some code that I wrote and broke into 5 separate questions on stack overflow. Some guy wanted to query Google Maps receive some JSON and then for each result found within that JSON do another query. I didn;t quite understand what he wanted at first and so actually there is some superfluous code here but I thought it would be useful to park my findings as to good practices for parsing JSON.
I use XHR requests. To parse the JSON, I use the ScriptControl. I have used this before. I have also seen a number of stack overflow questions which advocate third party libraries and I was puzzled by this. They all seem to take a mini-script approach of adding some javascript code to the script engine and calling it is cool but perhaps used too widely when there is a native solution available.
The key finding here is the use of VBA's CallByName function which can be used to query a JScriptTypeInfo Object Instance i.e. that which comes out of ScriptControl's Eval method.
CallByName can be used to get a member value; it can be used to query length of an array; it can be used to access elements of an array all with any javascript. Further I found some hasOwnProperty() method which allows defensive programming, so call this in cases where one thinks a member is missing. I also found some debugging sugar to stringify variables.
Look for some code review here. Will entertain suggestions, looking for best practice because in future looking to build J2EE application with REST interfaces that will use JSON and was planning to use Excel VBA as a debugging front end tool. Thanks.
'Tools->References->
'Microsoft Scripting Runtime
'Microsoft Script Control 1.0; {0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}; C:\Windows\SysWOW64\msscript.ocx
'Microsoft Xml, v6.0
Option Explicit
Option Private Module
Private Const sKEYNAME As String = "Server key 1"
'Public Const sKEY As String = "Your key goes here and uncomment"
Private Const sSEVENOAKS_PLACEID As String = "ChIJwd9bXUyt2EcRYv6GY0JRnCw" 'Place ID: ChIJwd9bXUyt2EcRYv6GY0JRnCw Sevenoaks , Sevenoaks, Kent, UK
Private Const sSEVENOAKS_LATITUDE_LONGITUDE As String = "51.2724,0.1909" '51.2724° N, 0.1909° E
Private Function GetScriptEngine() As ScriptControl
Static soScriptEngine As ScriptControl
If soScriptEngine Is Nothing Then
Set soScriptEngine = New ScriptControl
soScriptEngine.Language = "JScript"
soScriptEngine.AddCode GetJavaScriptLibrary("https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js")
soScriptEngine.AddCode "function getKeyValues(jsonObj) { " & _
" var dictionary = new ActiveXObject(""Scripting.Dictionary""); " & _
" var keys = new Array(); for (var i in jsonObj) { dictionary.add(i,jsonObj[i]); }; return dictionary; } "
soScriptEngine.AddCode "function setKeyValue(jsonObj, key, newItem) { jsonObj[key]=newItem; return jsonObj; }"
soScriptEngine.AddCode "function toVBString(jsonObj) { return JSON.stringify(jsonObj); }"
soScriptEngine.AddCode "function overrideToString(jsonObj) { jsonObj.toString = function() { return JSON.stringify(this); } }"
End If
Set GetScriptEngine = soScriptEngine
End Function
Private Function GetJavaScriptLibrary(ByVal sURL As String) As String
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
xHTTPRequest.Open "GET", sURL, False
xHTTPRequest.send
GetJavaScriptLibrary = xHTTPRequest.responseText
End Function
Private Function DecodeJsonString(ByVal JsonString As String) As Object
Dim oScriptEngine As ScriptControl
Set oScriptEngine = GetScriptEngine
Set DecodeJsonString = oScriptEngine.Eval("(" + JsonString + ")")
Call oScriptEngine.Run("overrideToString", DecodeJsonString) '* this gives JSON rendering instead of "[object Object]"
End Function
Private Function GetJSONPrimitive(ByVal obj As Object, ByVal sKey As String, Optional vDefaultValue As Variant) As Variant
Dim vRet As Variant
If obj.hasOwnProperty(sKey) Then
vRet = VBA.CallByName(obj, sKey, VbGet)
Else
vRet = vDefaultValue
End If
GetJSONPrimitive = vRet
End Function
Private Function GetJSONObject(ByVal obj As Object, ByVal sKey As String) As Object
Dim objReturn As Object
If obj.hasOwnProperty(sKey) Then
Set objReturn = VBA.CallByName(obj, sKey, VbGet)
Call GetScriptEngine.Run("overrideToString", objReturn) '* this gives JSON rendering instead of "[object Object]"
End If
Set GetJSONObject = objReturn
End Function
Private Function TestAll() As Boolean
Debug.Assert TestPlaceDetails
Debug.Assert TestNearbySearch
Debug.Assert TestAutoComplete
Debug.Assert BigTest
Debug.Assert EvenBiggerTest
Debug.Assert TestTextSearch 'biggest of all
TestAll = True
End Function
Private Function BigTest() As Boolean
Dim dicPlacesWithPlaceIds As Scripting.Dictionary
Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Sevenoaks")
ReDim v(1 To dicPlacesWithPlaceIds.Count + 1, 1 To 2)
v(1, 1) = "Place": v(1, 2) = "Lat, Long"
Dim lLoop As Long
For lLoop = 1 To dicPlacesWithPlaceIds.Count
Dim sPlace As String
sPlace = dicPlacesWithPlaceIds.Keys()(lLoop - 1)
Dim sPlaceID As String
sPlaceID = dicPlacesWithPlaceIds.Items()(lLoop - 1)
Dim dicPlaceDetails As Scripting.Dictionary
Set dicPlaceDetails = PlaceDetails(sKey, sPlaceID)
v(lLoop + 1, 1) = sPlace
v(lLoop + 1, 2) = dicPlaceDetails.Items()(0)
Next
'Stop
ActiveSheet.Cells(1, 1).CurrentRegion.Clear
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicPlacesWithPlaceIds.Count + 1, 2)).Value2 = v
BigTest = True
End Function
Private Function EvenBiggerTest() As Boolean
Dim dicPlacesWithPlaceIds As Scripting.Dictionary
Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Hamburg")
If dicPlacesWithPlaceIds.Count > 0 Then
Dim sTopPrediction As String
sTopPrediction = dicPlacesWithPlaceIds.Keys()(0)
Dim sTopPredictionPlaceId As String
sTopPredictionPlaceId = dicPlacesWithPlaceIds.Items()(0)
Dim dicPlaceDetails As Scripting.Dictionary
Set dicPlaceDetails = PlaceDetails(sKey, sTopPredictionPlaceId)
Dim sTopPredictionLocation As String
sTopPredictionLocation = dicPlaceDetails.Item("Location")
Dim dicNearbySearchResults As Scripting.Dictionary
Set dicNearbySearchResults = NearbySearch(sKey, sTopPredictionLocation, 100, "post office")
ReDim v(1 To dicNearbySearchResults.Count + 1, 1 To 5)
v(1, 1) = "Name": v(1, 2) = "PlaceId": v(1, 3) = "Address": v(1, 4) = "Vicinity": v(1, 5) = "Type0"
Dim lLoop As Long
For lLoop = 1 To dicNearbySearchResults.Count
Dim sPlaceIdLoop As String
sPlaceIdLoop = dicNearbySearchResults.Items()(lLoop - 1)
Set dicPlaceDetails = PlaceDetails(sKey, sPlaceIdLoop)
v(lLoop + 1, 1) = dicNearbySearchResults.Keys()(lLoop - 1)
v(lLoop + 1, 2) = sPlaceIdLoop
v(lLoop + 1, 3) = dicPlaceDetails.Item("Address")
If dicPlaceDetails.Exists("Vicinity") Then
v(lLoop + 1, 4) = dicPlaceDetails.Item("Vicinity")
End If
If dicPlaceDetails.Exists("Type0") Then
v(lLoop + 1, 5) = dicPlaceDetails.Item("Type0")
End If
Next
'Stop
ActiveSheet.Cells(1, 1).CurrentRegion.Clear
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicNearbySearchResults.Count + 1, 5)).Value2 = v
End If
EvenBiggerTest = True
End Function
Private Function TextSearch(ByVal sAPIKey As String, ByVal sSearchQuery As String, ByRef pdicFieldOrinals As Scripting.Dictionary) As Scripting.Dictionary
'
'Tools->References->
'Microsoft Scripting Runtime
Dim dicTextSearchResults As Scripting.Dictionary
Set dicTextSearchResults = New Scripting.Dictionary
Set pdicFieldOrinals = New Scripting.Dictionary
Dim psNextPageToken As String: psNextPageToken = ""
Do
If psNextPageToken <> "" Then
Application.Wait (Now() + CDate("00:00:05"))
End If
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
Dim sURL As String
sURL = "https://maps.googleapis.com/maps/api/place/textsearch/json?key=" & sAPIKey & "&query=" & sSearchQuery
If psNextPageToken <> "" Then sURL = sURL & "&pagetoken=" & psNextPageToken
xHTTPRequest.Open "GET", sURL
xHTTPRequest.send
While xHTTPRequest.readyState <> 4
DoEvents
Wend
If Len(xHTTPRequest.responseText) > 0 Then
'Debug.Print Left$(xHTTPRequest.responseText, 500)
Dim objJSON As Object
Set objJSON = DecodeJsonString(xHTTPRequest.responseText)
ParseTextSearchResponse objJSON, dicTextSearchResults, pdicFieldOrinals, psNextPageToken
End If
Loop Until psNextPageToken = ""
Set TextSearch = dicTextSearchResults
End Function
Private Function TestTextSearch() As Boolean
ActiveSheet.Cells(1, 1).CurrentRegion.Clear
Dim pdicFieldOrinals As Scripting.Dictionary
Dim dicTextSearchResults As Scripting.Dictionary
Set dicTextSearchResults = TextSearch(sKey, "london+restaurants", pdicFieldOrinals)
Dim dicDetails As Scripting.Dictionary
Set dicDetails = dicTextSearchResults.Item(dicTextSearchResults.Keys()(0))
Dim vGrid As Variant
vGrid = NestedDictionaryToGrid(dicTextSearchResults, pdicFieldOrinals)
ActiveSheet.Cells(1, 1).CurrentRegion.Clear
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicTextSearchResults.Count + 1, pdicFieldOrinals.Count)).Value2 = vGrid
TestTextSearch = True
End Function
Private Function ParseTextSearchResponse(ByVal objJSON As Object, _
ByVal dicTextSearchResults As Scripting.Dictionary, ByVal dicFieldOrinals As Scripting.Dictionary, _
ByRef psPageToken As String)
If Not objJSON Is Nothing Then
psPageToken = GetJSONPrimitive(objJSON, "next_page_token", "")
Dim sStatus As String
sStatus = GetJSONPrimitive(objJSON, "status")
If sStatus = "OK" Then
Dim objResults As Object
Set objResults = GetJSONObject(objJSON, "results")
Dim lLength As Long
lLength = GetJSONPrimitive(objResults, "length", -1)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim objResultLoop As Object
Set objResultLoop = GetJSONObject(objResults, CStr(lLoop))
Dim sName As String
sName = GetJSONPrimitive(objResultLoop, "name")
Dim dicKeys As Scripting.Dictionary
Set dicKeys = GetScriptEngine.Run("getKeyValues", objResultLoop)
Dim dicFlattenedDetails As Scripting.Dictionary
Set dicFlattenedDetails = New Scripting.Dictionary
Dim vKeyLoop As Variant
For Each vKeyLoop In dicKeys.Keys
If Not dicFieldOrinals.Exists(vKeyLoop) Then dicFieldOrinals.Add vKeyLoop, dicFieldOrinals.Count
Dim vValue As Variant: vValue = Empty
Select Case vKeyLoop
Case "formatted_address", "icon", "id", "name", "permanently_closed", "place_id", "price_level", "rating", "reference":
vValue = VBA.CallByName(objResultLoop, vKeyLoop, VbGet)
dicFlattenedDetails.Add vKeyLoop, vValue
Case "geometry":
dicFlattenedDetails.Add "geometry", ExtractLatitudeAndLongitude(GetJSONObject(objResultLoop, "geometry"))
Case "opening_hours":
dicFlattenedDetails.Add "opening_hours", ExtractOpeningHours(GetJSONObject(objResultLoop, "opening_hours"))
Case "types":
dicFlattenedDetails.Add "types", ExtractTypes(GetJSONObject(objResultLoop, "types"))
Case "photos":
'* NOT YET IMPLEMENTED
Case Else
Stop
End Select
Next vKeyLoop
Dim sPlaceID As String
sPlaceID = VBA.CallByName(objResultLoop, "place_id", VbGet)
dicTextSearchResults.Add sPlaceID, dicFlattenedDetails
Next
End If
End If
End Function
Private Function ExtractOpeningHours(ByVal objOpeningHours As Object) As String
Dim vOpenNow As Variant
vOpenNow = VBA.CallByName(objOpeningHours, "open_now", VbGet)
Dim bOpenNow As Boolean
bOpenNow = CBool(vOpenNow)
Dim objWeekdayText As Object
Set objWeekdayText = GetJSONObject(objOpeningHours, "weekday_text")
Dim lLength As Long
lLength = VBA.CallByName(objWeekdayText, "length", VbGet)
If lLength > 0 Then
Dim dicWeekdaysKeys As Scripting.Dictionary
Set dicWeekdaysKeys = GetScriptEngine.Run("getKeyValues", objWeekdayText)
Stop
End If
ExtractOpeningHours = VBA.IIf(bOpenNow, "open", "closed")
End Function
Private Function ExtractTypes(ByVal objTypes As Object) As String
Dim lLength As Long
lLength = VBA.CallByName(objTypes, "length", VbGet)
Dim dicTypes As Scripting.Dictionary
Set dicTypes = New Scripting.Dictionary
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim sTypeLoop As String
sTypeLoop = VBA.CallByName(objTypes, CStr(lLoop), VbGet)
dicTypes.Add sTypeLoop, 0
Next lLoop
ExtractTypes = VBA.Join(dicTypes.Keys, "|")
End Function
Private Function TestNearbySearch() As Boolean
Dim dicNearbySearchResults As Scripting.Dictionary
Set dicNearbySearchResults = NearbySearch(sKey, sSEVENOAKS_LATITUDE_LONGITUDE, 500, "restaurant")
Debug.Assert dicNearbySearchResults.Exists("Subway")
Debug.Assert dicNearbySearchResults.Item("Subway") = "ChIJ_yoN0_tN30cRnjjjqftbnSw"
TestNearbySearch = True
End Function
Public Function NearbySearch(ByVal sAPIKey As String, ByVal sLocationLatitudeLongitude As String, ByVal lRadius As Long, _
ByVal sSearchType As String)
'
'Tools->References->
'Microsoft Scripting Runtime
Dim dicNearbySearchResults As Scripting.Dictionary
Set dicNearbySearchResults = New Scripting.Dictionary
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/nearbysearch/json?key=" & sAPIKey & "&location=" & sLocationLatitudeLongitude & "&radius=" & lRadius & "&type=" & sSearchType
xHTTPRequest.send
While xHTTPRequest.readyState <> 4
DoEvents
Wend
If Len(xHTTPRequest.responseText) > 0 Then
Dim objJSON As Object
Set objJSON = DecodeJsonString(xHTTPRequest.responseText)
If Not objJSON Is Nothing Then
Dim sStatus As String
sStatus = GetJSONPrimitive(objJSON, "status")
If sStatus = "OK" Then
Dim objResults As Object
Set objResults = GetJSONObject(objJSON, "results")
Dim lLength As Long
lLength = VBA.CallByName(objResults, "length", VbGet)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim objResultLoop As Object
Set objResultLoop = GetJSONObject(objResults, CStr(lLoop))
Dim sName As String
sName = VBA.CallByName(objResultLoop, "name", VbGet)
Dim sPlaceID As String
sPlaceID = VBA.CallByName(objResultLoop, "place_id", VbGet)
dicNearbySearchResults.Add sName, sPlaceID
Next
End If
End If
End If
Set NearbySearch = dicNearbySearchResults
End Function
Private Function ExtractLatitudeAndLongitude(ByVal objGeometry As Object) As String
Dim objLocation As Object
Set objLocation = GetJSONObject(objGeometry, "location")
Dim sLatitude As String
sLatitude = VBA.CallByName(objLocation, "lat", VbGet)
Dim sLongitude As String
sLongitude = VBA.CallByName(objLocation, "lng", VbGet)
ExtractLatitudeAndLongitude = sLatitude & "," & sLongitude
End Function
Private Function TestPlaceDetails() As Boolean
Dim dicPlaceDetails As Scripting.Dictionary
Set dicPlaceDetails = PlaceDetails(sKey, sSEVENOAKS_PLACEID)
Debug.Assert dicPlaceDetails.Keys()(0) = "Location"
Debug.Assert dicPlaceDetails.Items()(0) = "51.27241,0.190898"
TestPlaceDetails = True
End Function
Public Function PlaceDetails(ByVal sAPIKey As String, ByVal sPlaceID As String) As Scripting.Dictionary
'Tools->References->
'Microsoft Scripting Runtime
Dim dicPlaceDetails As Scripting.Dictionary
Set dicPlaceDetails = New Scripting.Dictionary
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/details/json?key=" & sAPIKey & "&placeid=" & sPlaceID
xHTTPRequest.send
While xHTTPRequest.readyState <> 4
DoEvents
Wend
If Len(xHTTPRequest.responseText) > 0 Then
Dim objJSON As Object
Set objJSON = DecodeJsonString(xHTTPRequest.responseText)
If Not objJSON Is Nothing Then
Dim objResult As Object
Set objResult = GetJSONObject(objJSON, "result")
If Not objResult Is Nothing Then
'If objJSON.hasOwnProperty("result") Then
Dim objGeometry As Object
Set objGeometry = GetJSONObject(objResult, "geometry")
If Not objResult Is Nothing Then
Dim objLocation As Object
Set objLocation = GetJSONObject(objGeometry, "location")
If Not objLocation Is Nothing Then
Dim sLatitude As String
sLatitude = VBA.CallByName(objLocation, "lat", VbGet)
Dim sLongitude As String
sLongitude = VBA.CallByName(objLocation, "lng", VbGet)
dicPlaceDetails.Add "Location", sLatitude & "," & sLongitude
End If
dicPlaceDetails.Add "Address", VBA.CallByName(objResult, "formatted_address", VbGet)
dicPlaceDetails.Add "Name", VBA.CallByName(objResult, "name", VbGet)
If objResult.hasOwnProperty("vicinity") Then
dicPlaceDetails.Add "Vicinity", VBA.CallByName(objResult, "vicinity", VbGet)
End If
Dim objTypes As Object
Set objTypes = GetJSONObject(objResult, "types")
If Not objTypes Is Nothing Then
Dim lTypesLength As Long
lTypesLength = VBA.CallByName(objTypes, "length", VbGet)
Dim sType0 As String
sType0 = VBA.CallByName(objTypes, "0", VbGet)
dicPlaceDetails.Add "Type0", sType0
End If
dicPlaceDetails.Add "PlaceId", sPlaceID
End If
End If
End If
End If
Set PlaceDetails = dicPlaceDetails
End Function
Private Function TestAutoComplete() As Boolean
Dim dicPlacesWithPlaceIds As Scripting.Dictionary
Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Sevenoaks")
Debug.Assert dicPlacesWithPlaceIds.Keys()(0) = "Sevenoaks, United Kingdom"
Debug.Assert dicPlacesWithPlaceIds.Items()(0) = sSEVENOAKS_PLACEID
TestAutoComplete = True
End Function
Public Function AutoComplete(ByVal sAPIKey As String, ByVal sPlaceText As String) As Scripting.Dictionary
'Tools->References->
'Microsoft Scripting Runtime
Dim dicPlacesWithPlaceIds As Scripting.Dictionary
Set dicPlacesWithPlaceIds = New Scripting.Dictionary
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/autocomplete/json?key=" & sAPIKey & "&input=" & sPlaceText & "&sensor=false", False
xHTTPRequest.send
While xHTTPRequest.readyState <> 4
DoEvents
Wend
If Len(xHTTPRequest.responseText) > 0 Then
Dim objJSON As Object
Set objJSON = DecodeJsonString(xHTTPRequest.responseText)
If Not objJSON Is Nothing Then
Dim objPredictions As Object
Set objPredictions = GetJSONObject(objJSON, "predictions")
If Not objPredictions Is Nothing Then
Dim lLength As Long
lLength = VBA.CallByName(objPredictions, "length", VbGet)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim objPredictionLoop As Object
Set objPredictionLoop = GetJSONObject(objPredictions, CStr(lLoop))
Dim sPlaceDescription As String
sPlaceDescription = VBA.CallByName(objPredictionLoop, "description", VbGet)
Dim sPlaceID As String
sPlaceID = VBA.CallByName(objPredictionLoop, "place_id", VbGet)
dicPlacesWithPlaceIds.Add sPlaceDescription, sPlaceID
'Stop
Next
'Stop
End If
End If
'Stop
End If
Set AutoComplete = dicPlacesWithPlaceIds
'Debug.Print xHTTPRequest.responseText
End Function
Private Function NestedDictionaryToGrid(ByVal dicData As Scripting.Dictionary, ByVal dicFieldOrdinals As Scripting.Dictionary) As Variant
ReDim vRet(1 To dicData.Count + 1, 1 To dicFieldOrdinals.Count)
Dim vFieldKeyLoop As Variant
For Each vFieldKeyLoop In dicFieldOrdinals.Keys
vRet(1, dicFieldOrdinals.Item(vFieldKeyLoop) + 1) = vFieldKeyLoop
Next
Dim lRowLoop As Long: lRowLoop = 1
Dim vDataKeyLoop As Variant
For Each vDataKeyLoop In dicData.Keys
lRowLoop = lRowLoop + 1
Dim dicDetails As Scripting.Dictionary
Set dicDetails = dicData.Item(vDataKeyLoop)
For Each vFieldKeyLoop In dicFieldOrdinals.Keys
vRet(lRowLoop, dicFieldOrdinals.Item(vFieldKeyLoop) + 1) = dicDetails.Item(vFieldKeyLoop)
Next
Next vDataKeyLoop
NestedDictionaryToGrid = vRet
End Function
