Parsing JSON in Excel VBA

Question

I have the same issue as in Excel VBA: Parsed JSON Object Loop but cannot find any solution. My JSON has nested objects so suggested solution like VBJSON and vba-json do not

Answer 1

Thanks a lot Codo.

I've just updated and completed what you have done to :

• serialize the json (I need it to inject the json in a text-like document)

• add, remove and update node (who knows)

  Option Explicit
  
  Private ScriptEngine As ScriptControl
  
  Public Sub InitScriptEngine()
      Set ScriptEngine = New ScriptControl
      ScriptEngine.Language = "JScript"
      ScriptEngine.AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
      ScriptEngine.AddCode "function getType(jsonObj, propertyName) {return typeof(jsonObj[propertyName]);}"
      ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
      ScriptEngine.AddCode "function addKey(jsonObj, propertyName, value) { jsonObj[propertyName] = value; return jsonObj;}"
      ScriptEngine.AddCode "function removeKey(jsonObj, propertyName) { var json = jsonObj; delete json[propertyName]; return json }"
  End Sub
  Public Function removeJSONProperty(ByVal JsonObject As Object, propertyName As String)
      Set removeJSONProperty = ScriptEngine.Run("removeKey", JsonObject, propertyName)
  End Function
  
  Public Function updateJSONPropertyValue(ByVal JsonObject As Object, propertyName As String, value As String) As Object
      Set updateJSONPropertyValue = ScriptEngine.Run("removeKey", JsonObject, propertyName)
      Set updateJSONPropertyValue = ScriptEngine.Run("addKey", JsonObject, propertyName, value)
  End Function
  
  
  
  Public Function addJSONPropertyValue(ByVal JsonObject As Object, propertyName As String, value As String) As Object
      Set addJSONPropertyValue = ScriptEngine.Run("addKey", JsonObject, propertyName, value)
  End Function
  Public Function DecodeJsonString(ByVal JsonString As String)
  InitScriptEngine
      Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")")
  End Function
  
  Public Function GetProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Variant
      GetProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
  End Function
  
  Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
      Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
  End Function
  
  Public Function SerializeJSONObject(ByVal JsonObject As Object) As String()
      Dim Length As Integer
      Dim KeysArray() As String
      Dim KeysObject As Object
      Dim Index As Integer
      Dim Key As Variant
      Dim tmpString As String
      Dim tmpJSON As Object
      Dim tmpJSONArray() As Variant
      Dim tmpJSONObject() As Variant
      Dim strJsonObject As String
      Dim tmpNbElement As Long, i As Long
      InitScriptEngine
      Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
  
      Length = GetProperty(KeysObject, "length")
      ReDim KeysArray(Length - 1)
      Index = 0
      For Each Key In KeysObject
      tmpString = ""
          If ScriptEngine.Run("getType", JsonObject, Key) = "object" Then
      'MsgBox "object " & SerializeJSONObject(GetObjectProperty(JsonObject, Key))(0)
              Set tmpJSON = GetObjectProperty(JsonObject, Key)
              strJsonObject = VBA.Replace(ScriptEngine.Run("getKeys", tmpJSON), " ", "")
              tmpNbElement = Len(strJsonObject) - Len(VBA.Replace(strJsonObject, ",", ""))
  
              If VBA.IsNumeric(Left(ScriptEngine.Run("getKeys", tmpJSON), 1)) = True Then
  
                  ReDim tmpJSONArray(tmpNbElement)
                  For i = 0 To tmpNbElement
                      tmpJSONArray(i) = GetProperty(tmpJSON, i)
                  Next
                      tmpString = "[" & Join(tmpJSONArray, ",") & "]"
              Else
                  tmpString = "{" & Join(SerializeJSONObject(tmpJSON), ", ") & "}"
              End If
  
          Else
                  tmpString = GetProperty(JsonObject, Key)
  
          End If
  
          KeysArray(Index) = Key & ": " & tmpString
          Index = Index + 1
      Next
  
      SerializeJSONObject = KeysArray
  
  End Function
  
  Public Function GetKeys(ByVal JsonObject As Object) As String()
      Dim Length As Integer
      Dim KeysArray() As String
      Dim KeysObject As Object
      Dim Index As Integer
      Dim Key As Variant
  InitScriptEngine
      Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
      Length = GetProperty(KeysObject, "length")
      ReDim KeysArray(Length - 1)
      Index = 0
      For Each Key In KeysObject
          KeysArray(Index) = Key
          Index = Index + 1
      Next
      GetKeys = KeysArray
  End Function