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 work for me  I also fixed one of them to work properly but the result was a call stack overflow because of to many recursion of the doProcess function   The best solution appears to be the jsonDecode function seen in the original post  It is very fast and highly effectively effective  my object structure is all there in a generic VBA Object of type JScriptTypeInfo   The issue at this point is that I cannot determine what will be the structure of the objects  therefore  I do not know beforehand the keys that will reside in each generic objects  I need to loop through the generic VBA Object to acquire the keys properties    If my parsing javascript function could trigger a VBA function or sub  that would be excellent

User · Accepted Answer

If you want to build on top of ScriptControl  you can add a few helper method to get at the required information  The JScriptTypeInfo object is a bit unfortunate  it contains all the relevant information  as you can see in the Watch window  but it seems impossible to get at it with VBA  However  the Javascript engine can help us   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 getKeys jsonObj    var keys   new Array    for  var i in jsonObj    keys push i     return keys      End Sub  Public Function DecodeJsonString ByVal JsonString As String      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 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      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   Public Sub TestJsonAccess       Dim JsonString As String     Dim JsonObject As Object     Dim Keys   As String     Dim Value As Variant     Dim j As Variant      InitScriptEngine      JsonString       key1      val1      key2        key3      val3            Set JsonObject   DecodeJsonString CStr JsonString       Keys   GetKeys JsonObject       Value   GetProperty JsonObject   key1       Set Value   GetObjectProperty JsonObject   key2   End Sub   A few notes    If the JScriptTypeInfo instance refers to a Javascript object  For Each     Next won t work  However  it does work if it refers to a Javascript array  see GetKeys function   The access properties whose name is only known at run-time  use the functions GetProperty and GetObjectProperty  The Javascript array provides the properties length  0  Item 0  1  Item 1 etc  With the VBA dot notation  jsonObject property   only the length property is accessible and only if you declare a variable called length with all lowercase letters  Otherwise the case doesn t match and it won t find it  The other properties are not valid in VBA  So better use the GetProperty function  The code uses early binding  So you have to add a reference to  Microsoft Script Control 1 0   You have to call InitScriptEngine once before using the other functions to do some basic initialization

User · Answer

Two small contributions to Codo s answer      recursive  version of GetObjectProperty Public Function GetObjectProperty ByVal JsonObject As Object  ByVal propertyName As String  As Object     Dim names   As String     Dim i As Integer      names   Split propertyName            For i   0 To UBound names          Set JsonObject   ScriptEngine Run  getProperty   JsonObject  names i       Next      Set GetObjectProperty   JsonObject End Function    shortcut to object array Public Function GetObjectArrayProperty ByVal JsonObject As Object  ByVal propertyName As String  As Object       Dim a   As Object     Dim i As Integer     Dim l As Integer      Set JsonObject   GetObjectProperty JsonObject  propertyName       l   GetProperty JsonObject   length   - 1      ReDim a l       For i   0 To l         Set a i    GetObjectProperty JsonObject  CStr i       Next      GetObjectArrayProperty   a End Function   So now I can do stuff like   Dim JsonObject As Object Dim Value   As Object Dim i As Integer Dim Total As Double  Set JsonObject   DecodeJsonString CStr request responseText    Value   GetObjectArrayProperty JsonObject   d Data    For i   0 To UBound Value      Total   Total   Value i  Amount Next

User · Answer

To parse JSON in VBA without adding a huge library to your workbook project  I created the following solution  It s extremely fast and stores all of the keys and values in a dictionary for easy access  Function ParseJSON json   Optional key     quot obj quot   As Object     p   1     token   Tokenize json      Set dic   CreateObject  quot Scripting Dictionary quot       If token p     quot   quot  Then ParseObj key Else ParseArr key     Set ParseJSON   dic End Function  Function ParseObj key       Do  p   p   1         Select Case token p              Case  quot   quot              Case  quot   quot    ParseArr key             Case  quot   quot                         If token p   1     quot   quot  Then                            p   p   1                            dic Add key   quot null quot                         Else                            ParseObj key                        End If                          Case  quot   quot    key   ReducePath key   Exit Do             Case  quot   quot    key   key  amp   quot   quot   amp  token p - 1              Case  quot   quot    key   ReducePath key              Case Else  If token p   1   lt  gt   quot   quot  Then dic Add key  token p          End Select     Loop End Function  Function ParseArr key       Dim e amp      Do  p   p   1         Select Case token p              Case  quot   quot              Case  quot   quot    ParseObj key  amp  ArrayID e              Case  quot   quot    ParseArr key             Case  quot   quot    Exit Do             Case  quot   quot    key   key  amp  ArrayID e              Case  quot   quot    e   e   1             Case Else  dic Add key  amp  ArrayID e   token p          End Select     Loop End Function  The code above does use a few helper functions  but the above is the meat of it  The strategy used here is to employ a recursive tokenizer  I found it interesting enough to write an article about this solution on Medium  It explains the details  Here is the full  yet surprisingly short  code listing  including all of the helper functions   -------------------------------------------------------------------   VBA JSON Parser  ------------------------------------------------------------------- Option Explicit Private p amp   token  dic Function ParseJSON json   Optional key     quot obj quot   As Object     p   1     token   Tokenize json      Set dic   CreateObject  quot Scripting Dictionary quot       If token p     quot   quot  Then ParseObj key Else ParseArr key     Set ParseJSON   dic End Function Function ParseObj key       Do  p   p   1         Select Case token p              Case  quot   quot              Case  quot   quot    ParseArr key             Case  quot   quot                         If token p   1     quot   quot  Then                            p   p   1                            dic Add key   quot null quot                         Else                            ParseObj key                        End If                          Case  quot   quot    key   ReducePath key   Exit Do             Case  quot   quot    key   key  amp   quot   quot   amp  token p - 1              Case  quot   quot    key   ReducePath key              Case Else  If token p   1   lt  gt   quot   quot  Then dic Add key  token p          End Select     Loop End Function Function ParseArr key       Dim e amp      Do  p   p   1         Select Case token p              Case  quot   quot              Case  quot   quot    ParseObj key  amp  ArrayID e              Case  quot   quot    ParseArr key             Case  quot   quot    Exit Do             Case  quot   quot    key   key  amp  ArrayID e              Case  quot   quot    e   e   1             Case Else  dic Add key  amp  ArrayID e   token p          End Select     Loop End Function  -------------------------------------------------------------------   Support Functions  ------------------------------------------------------------------- Function Tokenize s       Const Pattern    quot  quot  quot      quot  quot            quot  quot     -     0  1-9  d        d       eE    -   d     w     s quot  quot      quot      Tokenize   RExtract s  Pattern  True  End Function Function RExtract s   Pattern  Optional bGroup1Bias As Boolean  Optional bGlobal As Boolean   True    Dim c amp   m  n  v   With CreateObject  quot vbscript regexp quot        Global   bGlobal      MultiLine   False      IgnoreCase   True      Pattern   Pattern     If  TEST s  Then       Set m    Execute s        ReDim v 1 To m Count        For Each n In m         c   c   1         v c    n value         If bGroup1Bias Then If Len n submatches 0   Or n value    quot  quot  quot  quot  quot  quot  Then v c    n submatches 0        Next     End If   End With   RExtract   v End Function Function ArrayID  e      ArrayID    quot   quot   amp  e  amp   quot   quot  End Function Function ReducePath  key       If InStr key   quot   quot   Then ReducePath   Left key  InStrRev key   quot   quot   - 1  End Function Function ListPaths dic      Dim s   v     For Each v In dic         s   s  amp  v  amp   quot  -- gt   quot   amp  dic v   amp  vbLf     Next     Debug Print s End Function Function GetFilteredValues dic  match      Dim c amp   i amp   v  w     v   dic keys     ReDim w 1 To dic Count      For i   0 To UBound v          If v i  Like match Then             c   c   1             w c    dic v i           End If     Next     ReDim Preserve w 1 To c      GetFilteredValues   w End Function Function GetFilteredTable dic  cols      Dim c amp   i amp   j amp   v  w  z     v   dic keys     z   GetFilteredValues dic  cols 0       ReDim w 1 To UBound z   1 To UBound cols    1      For j   1 To UBound cols    1          z   GetFilteredValues dic  cols j - 1            For i   1 To UBound z              w i  j    z i           Next     Next     GetFilteredTable   w End Function Function OpenTextFile  f      With CreateObject  quot ADODB Stream quot            Charset    quot utf-8 quot           Open          LoadFromFile f         OpenTextFile    ReadText     End With End Function

User · Answer

UPDATE 3  Sep 24  17   Check VBA-JSON-parser on GitHub for the latest version and examples  Import JSON bas module into the VBA project for JSON processing   UPDATE 2  Oct 1  16   However if you do want to parse JSON on 64-bit Office with ScriptControl  then this answer may help you to get ScriptControl to work on 64-bit   UPDATE  Oct 26  15   Note that a ScriptControl-based approachs makes the system vulnerable in some cases  since they allows a direct access to the drives  and other stuff  for the malicious JS code via ActiveX s  Let s suppose you are parsing web server response JSON  like JsonString     a  function    new ActiveXObject  Scripting FileSystemObject    CreateTextFile  C   Test txt          After evaluating it you ll find new created file C  Test txt  So JSON parsing with ScriptControl ActiveX is not a good idea   Trying to avoid that  I ve created JSON parser based on RegEx s  Objects    are represented by dictionaries  that makes possible to use dictionary s properties and methods   Count   Exists     Item     Items   Keys  Arrays    are the conventional zero-based VB arrays  so UBound   shows the number of elements  Here is the code with some usage examples   Option Explicit  Sub JsonTest       Dim strJsonString As String     Dim varJson As Variant     Dim strState As String     Dim varItem As Variant        parse JSON string to object       root element can be the object    or the array        strJsonString       a        0    value        stuff     content       b null       ParseJson strJsonString  varJson  strState        checking the structure step by step     Select Case False   if any of the checks is False  the sequence is interrupted         Case IsObject varJson    if root JSON element is object             Case varJson Exists  a     having property a          Case IsArray varJson  a      which is array          Case UBound varJson  a     gt   3   having not less than 4 elements          Case IsArray varJson  a   3     where forth element is array          Case UBound varJson  a   3     0   having the only element          Case IsObject varJson  a   3  0     which is object          Case varJson  a   3  0  Exists  stuff     having property stuff          Case Else             MsgBox  Check the structure step by step   amp  vbCrLf  amp  varJson  a   3  0   stuff     then show the value of the last one property      End Select        direct access to the property if sure of structure     MsgBox  Direct access to the property   amp  vbCrLf  amp  varJson Item  a   3  0  Item  stuff     content        traversing each element in array     For Each varItem In varJson  a             show the structure of the element         MsgBox  The structure of the element    amp  vbCrLf  amp  BeautifyJson varItem      Next        show the full structure starting from root element     MsgBox  The full structure starting from root element    amp  vbCrLf  amp  BeautifyJson varJson   End Sub  Sub BeautifyTest         put sourse JSON string to  desktop source json  file       processed JSON will be saved to  desktop result json  file     Dim strDesktop As String     Dim strJsonString As String     Dim varJson As Variant     Dim strState As String     Dim strResult As String     Dim lngIndent As Long      strDesktop   CreateObject  WScript Shell   SpecialFolders Item  Desktop       strJsonString   ReadTextFile strDesktop  amp    source json   -2      ParseJson strJsonString  varJson  strState     If strState  lt  gt   Error  Then         strResult   BeautifyJson varJson          WriteTextFile strResult  strDesktop  amp    result json   -1     End If     CreateObject  WScript Shell   PopUp strState  1    64 End Sub  Sub ParseJson ByVal strContent As String  varJson As Variant  strState As String        strContent - source JSON string       varJson - created object or array to be returned as result       strState - Object Array Error depending on processing to be returned as state     Dim objTokens As Object     Dim objRegEx As Object     Dim bMatched As Boolean      Set objTokens   CreateObject  Scripting Dictionary       Set objRegEx   CreateObject  VBScript RegExp       With objRegEx           specification http   www json org           Global   True          MultiLine   True          IgnoreCase   True          Pattern                           s                          Tokenize objTokens  objRegEx  strContent  bMatched   str           Pattern         -       d    d     d   d  e     -    d     s                       Tokenize objTokens  objRegEx  strContent  bMatched   num           Pattern         -       d    d     d   d      s                       Tokenize objTokens  objRegEx  strContent  bMatched   num           Pattern     b   true false null     s                       Tokenize objTokens  objRegEx  strContent  bMatched   cst           Pattern     b A-Za-z   w     s        unspecified name without quotes         Tokenize objTokens  objRegEx  strContent  bMatched   nam           Pattern     s          strContent    Replace strContent               MultiLine   False         Do             bMatched   False              Pattern     lt  d    str nam  gt    lt  d    str num obj arr cst  gt               Tokenize objTokens  objRegEx  strContent  bMatched   prp               Pattern          lt  d prp gt      lt  d prp gt                     Tokenize objTokens  objRegEx  strContent  bMatched   obj               Pattern          lt  d    str num obj arr cst  gt      lt  d    str num obj arr cst  gt                     Tokenize objTokens  objRegEx  strContent  bMatched   arr          Loop While bMatched          Pattern      lt  d    obj arr  gt      unspecified top level array         If Not   Test strContent  And objTokens Exists strContent   Then             varJson   Null             strState    Error          Else             Retrieve objTokens  objRegEx  strContent  varJson             strState   IIf IsObject varJson    Object    Array           End If     End With End Sub  Sub Tokenize objTokens  objRegEx  strContent  bMatched  strType      Dim strKey As String     Dim strRes As String     Dim lngCopyIndex As Long     Dim objMatch As Object      strRes          lngCopyIndex   1     With objRegEx         For Each objMatch In  Execute strContent              strKey     lt    amp  objTokens Count  amp  strType  amp    gt               bMatched   True             With objMatch                 objTokens strKey     Value                 strRes   strRes  amp  Mid strContent  lngCopyIndex   FirstIndex - lngCopyIndex   1   amp  strKey                 lngCopyIndex    FirstIndex    Length   1             End With         Next         strContent   strRes  amp  Mid strContent  lngCopyIndex  Len strContent  - lngCopyIndex   1      End With End Sub  Sub Retrieve objTokens  objRegEx  strTokenKey  varTransfer      Dim strContent As String     Dim strType As String     Dim objMatches As Object     Dim objMatch As Object     Dim strName As String     Dim varValue As Variant     Dim objArrayElts As Object      strType   Left Right strTokenKey  4   3      strContent   objTokens strTokenKey      With objRegEx          Global   True         Select Case strType             Case  obj                   Pattern     lt  d  w 3  gt                   Set objMatches    Execute strContent                  Set varTransfer   CreateObject  Scripting Dictionary                   For Each objMatch In objMatches                     Retrieve objTokens  objRegEx  objMatch Value  varTransfer                 Next             Case  prp                   Pattern     lt  d  w 3  gt                   Set objMatches    Execute strContent                   Retrieve objTokens  objRegEx  objMatches 0  Value  strName                 Retrieve objTokens  objRegEx  objMatches 1  Value  varValue                 If IsObject varValue  Then                     Set varTransfer strName    varValue                 Else                     varTransfer strName    varValue                 End If             Case  arr                   Pattern     lt  d  w 3  gt                   Set objMatches    Execute strContent                  Set objArrayElts   CreateObject  Scripting Dictionary                   For Each objMatch In objMatches                     Retrieve objTokens  objRegEx  objMatch Value  varValue                     If IsObject varValue  Then                         Set objArrayElts objArrayElts Count    varValue                     Else                         objArrayElts objArrayElts Count    varValue                     End If                     varTransfer   objArrayElts Items                 Next             Case  nam                  varTransfer   strContent             Case  str                  varTransfer   Mid strContent  2  Len strContent  - 2                  varTransfer   Replace varTransfer                               varTransfer   Replace varTransfer                             varTransfer   Replace varTransfer                             varTransfer   Replace varTransfer    b   Chr 8                   varTransfer   Replace varTransfer    f   Chr 12                   varTransfer   Replace varTransfer    n   vbLf                  varTransfer   Replace varTransfer    r   vbCr                  varTransfer   Replace varTransfer    t   vbTab                   Global   False                  Pattern      u 0-9a-fA-F  4                   Do While  Test varTransfer                      varTransfer    Replace varTransfer  ChrW    amp H   amp  Right  Execute varTransfer  0  Value  4     1                   Loop             Case  num                  varTransfer   Evaluate strContent              Case  cst                  Select Case LCase strContent                      Case  true                          varTransfer   True                     Case  false                          varTransfer   False                     Case  null                          varTransfer   Null                 End Select         End Select     End With End Sub  Function BeautifyJson varJson As Variant  As String     Dim strResult As String     Dim lngIndent As Long     BeautifyJson          lngIndent   0     BeautyTraverse BeautifyJson  lngIndent  varJson  vbTab  1 End Function  Sub BeautyTraverse strResult As String  lngIndent As Long  varElement As Variant  strIndent As String  lngStep As Long      Dim arrKeys   As Variant     Dim lngIndex As Long     Dim strTemp As String      Select Case VarType varElement          Case vbObject             If varElement Count   0 Then                 strResult   strResult  amp                   Else                 strResult   strResult  amp       amp  vbCrLf                 lngIndent   lngIndent   lngStep                 arrKeys   varElement Keys                 For lngIndex   0 To UBound arrKeys                      strResult   strResult  amp  String lngIndent  strIndent   amp        amp  arrKeys lngIndex   amp        amp                           BeautyTraverse strResult  lngIndent  varElement arrKeys lngIndex    strIndent  lngStep                     If Not  lngIndex   UBound arrKeys   Then strResult   strResult  amp                          strResult   strResult  amp  vbCrLf                 Next                 lngIndent   lngIndent - lngStep                 strResult   strResult  amp  String lngIndent  strIndent   amp                  End If         Case Is  gt   vbArray             If UBound varElement    -1 Then                 strResult   strResult  amp                   Else                 strResult   strResult  amp       amp  vbCrLf                 lngIndent   lngIndent   lngStep                 For lngIndex   0 To UBound varElement                      strResult   strResult  amp  String lngIndent  strIndent                      BeautyTraverse strResult  lngIndent  varElement lngIndex   strIndent  lngStep                     If Not  lngIndex   UBound varElement   Then strResult   strResult  amp                          strResult   strResult  amp  vbCrLf                 Next                 lngIndent   lngIndent - lngStep                 strResult   strResult  amp  String lngIndent  strIndent   amp                  End If         Case vbInteger  vbLong  vbSingle  vbDouble             strResult   strResult  amp  varElement         Case vbNull             strResult   strResult  amp   Null          Case vbBoolean             strResult   strResult  amp  IIf varElement   True    False           Case Else             strTemp   Replace varElement                           strTemp   Replace strTemp                         strTemp   Replace strTemp                         strTemp   Replace strTemp  Chr 8     b               strTemp   Replace strTemp  Chr 12     f               strTemp   Replace strTemp  vbLf    n               strTemp   Replace strTemp  vbCr    r               strTemp   Replace strTemp  vbTab    t               strResult   strResult  amp        amp  strTemp  amp           End Select  End Sub  Function ReadTextFile strPath As String  lngFormat As Long  As String       lngFormat -2 - System default  -1 - Unicode  0 - ASCII     With CreateObject  Scripting FileSystemObject   OpenTextFile strPath  1  False  lngFormat          ReadTextFile              If Not  AtEndOfStream Then ReadTextFile    ReadAll          Close     End With End Function  Sub WriteTextFile strContent As String  strPath As String  lngFormat As Long      With CreateObject  Scripting FileSystemObject   OpenTextFile strPath  2  True  lngFormat           Write  strContent           Close     End With End Sub   One more opportunity of this JSON RegEx parser is that it works on 64-bit Office  where ScriptControl isn t available   INITIAL  May 27  15   Here is one more method to parse JSON in VBA  based on ScriptControl ActiveX  without external libraries   Sub JsonTest        Dim Dict  Temp  Text  Keys  Items        Converting JSON string to appropriate nested dictionaries structure       Dictionaries have numeric keys for JSON Arrays  and string keys for JSON Objects       Returns Nothing in case of any JSON syntax issues     Set Dict   GetJsonDict   a    stuff  result      b             You can use For Each     Next and For     Next loops through keys and items     Keys   Dict Keys     Items   Dict Items        Referring directly to the necessary property if sure  without any checks     MsgBox Dict  a   0  0   stuff          Auxiliary DrillDown   function       Drilling down the structure  sequentially checking if each level exists     Select Case False     Case DrillDown Dict   a   Temp          Case DrillDown Temp  0  Temp          Case DrillDown Temp  0  Temp          Case DrillDown Temp   stuff       Text      Case Else           Structure is consistent  requested value found         MsgBox Text     End Select  End Sub  Function GetJsonDict JsonString As String      With CreateObject  ScriptControl            Language    JScript           ExecuteStatement  function gettype sample   return    toString call sample  slice 8  -1             ExecuteStatement  function evaljson json  er   try  var sample   eval       json         var type   gettype sample   if type     Array   amp  amp  type     Object    return er   else  return getdict sample     catch e   return er              ExecuteStatement  function getdict sample   var type   gettype sample   if type     Array   amp  amp  type     Object   return sample  var dict   new ActiveXObject  Scripting Dictionary    if type     Array    for var key   0  key  lt  sample length  key     dict add key  getdict sample key       else  for var key in sample   dict add key  getdict sample key       return dict            Set GetJsonDict    Run  evaljson   JsonString  Nothing      End With End Function  Function DrillDown Source  Prop  Target  Value      Select Case False     Case TypeName Source     Dictionary      Case Source exists Prop      Case Else         Select Case True         Case TypeName Source Prop      Dictionary              Set Target   Source Prop              Value   Empty         Case IsObject Source Prop               Set Value   Source Prop              Set Target   Nothing         Case Else             Value   Source Prop              Set Target   Nothing         End Select         DrillDown   True         Exit Function     End Select     DrillDown   False End Function

User · Answer

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    amp  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        amp  Join tmpJSONArray        amp                  Else                 tmpString        amp  Join SerializeJSONObject tmpJSON          amp                  End If          Else                 tmpString   GetProperty JsonObject  Key           End If          KeysArray Index    Key  amp        amp  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

User · Answer

Simpler way you can go array myitem 0  in VB code  my full answer here parse and stringify  serialize    Use the  this  object in js  ScriptEngine AddCode  Object prototype myitem function  i     return this i          Then you can go array myitem 0   Private ScriptEngine As ScriptControl  Public Sub InitScriptEngine       Set ScriptEngine   New ScriptControl     ScriptEngine Language    JScript      ScriptEngine AddCode  Object prototype myitem function  i     return this i            Set foo   ScriptEngine Eval          1234  2345             JSON array     Debug Print foo myitem 1    method case sensitive      Set foo   ScriptEngine Eval            key1   23     key2   2345             JSON key value     Debug Print foo myitem  key1     WTF  End Sub

User · Answer

This works for me under Excel and a big JSON files using JSON query translated in to native form   https   github com VBA-tools VBA-JSON I am able parse node like  item something  and get value using simple command    MsgBox Json  item    something     What s nice

User · Answer

As Json is nothing but strings so it can easily be handled if we can manipulate it the right way  no matter how complex the structure is  I don t think it is necessary to use any external library or converter to do the trick  Here is an example where I ve parsed json data using string manipulation   Sub FetchData       Dim str As Variant  N amp   R amp       With New XMLHTTP60          Open  GET    https   oresapp asicanada net ores imis services api member  address  amp callback angular callbacks  0 amp city  amp companyName  amp personName    False          send         str   Split  responseText        Id          End With      N   UBound str       For R   1 To N         Cells R  1    Split Split str R    FullName        1         0          Cells R  2    Split Split str R    Phone        1         0          Cells R  3    Split Split str R    Email        1         0      Next R End Sub

User · Answer

Lots of good answers here - just chipping in my own   I had a requirement to parse a very specific JSON string  representing the results of making a web-API call  The JSON described a list of objects  and looked something like this                property1    foo         property2    bar         timeOfDay    2019-09-30T00 00 00         numberOfHits   98        isSpecial   false        comment    just to be awkward  this contains a comma                   property1    fool         property2    barrel         timeOfDay    2019-10-31T00 00 00         numberOfHits   11        isSpecial   false        comment   null                  There are a few things to note about this    The JSON should always describe a list  even if empty   which should only contain objects  The objects in the list should only contain properties with simple types  string   date   number   boolean or null   The value of a property may contain a comma - which makes parsing the JSON somewhat harder - but may not contain any quotes  because I m too lazy to deal with that     The ParseListOfObjects function in the code below takes the JSON string as input  and returns a Collection representing the items in the list  Each item is represented as a Dictionary  where the keys of the dictionary correspond to the names of the object s properties  The values are automatically converted to the appropriate type  String  Date  Double  Boolean - or Empty if the value is null    Your VBA project will need a reference to the Microsoft Scripting Runtime library to use the Dictionary object - though it would not be difficult to remove this dependency if you use a different way of encoding the results   Here s my JSON bas   Option Explicit    NOTE  a fully-featured JSON parser in VBA would be a beast    This simple parser only supports VERY simple JSON  which is all we need     Specifically  it supports JSON comprising a list of objects  each of which has only simple properties   Private Const strSTART OF LIST As String       Private Const strEND OF LIST As String        Private Const strLIST DELIMITER As String        Private Const strSTART OF OBJECT As String       Private Const strEND OF OBJECT As String        Private Const strOBJECT PROPERTY NAME VALUE SEPARATOR As String        Private Const strQUOTE As String         Private Const strNULL VALUE As String    null  Private Const strTRUE VALUE As String    true  Private Const strFALSE VALUE As String    false    Public Function ParseListOfObjects ByVal strJson As String  As Collection        Takes a JSON string that represents a list of objects  where each object has only simple value properties   and       returns a collection of dictionary objects  where the keys and values of each dictionary represent the names and       values of the JSON object properties       Set ParseListOfObjects   New Collection      Dim strList As String  strList   Trim strJson         Check we have a list     If Left strList  Len strSTART OF LIST    lt  gt  strSTART OF LIST       Or Right strList  Len strEND OF LIST    lt  gt  strEND OF LIST Then         Err Raise vbObjectError  Description   The provided JSON does not appear to be a list  it does not start with     amp  strSTART OF LIST  amp     and end with     amp  strEND OF LIST  amp           End If        Get the list item text  between the   and        Dim strBody As String  strBody   Trim Mid strList  1   Len strSTART OF LIST   Len strList  - Len strSTART OF LIST  - Len strEND OF LIST         If strBody      Then         Exit Function     End If        Check we have a list of objects     If Left strBody  Len strSTART OF OBJECT    lt  gt  strSTART OF OBJECT Then         Err Raise vbObjectError  Description   The provided JSON does not appear to be a list of objects  the content of the list does not start with     amp  strSTART OF OBJECT  amp           End If        We now have something like             property   value    property   value      property   value    property   value              so we can t just split on a comma to get the various items  because the items themselves have commas in them         HOWEVER  since we know we re dealing with very simple JSON that has no nested objects  we can split on      because       that should only appear between items  That ll mean that all but the last item will be missing it s closing brace      Dim astrItems   As String  astrItems   Split strBody  strEND OF OBJECT  amp  strLIST DELIMITER       Dim ixItem As Long     For ixItem   LBound astrItems  To UBound astrItems           Dim strItem As String  strItem   Trim astrItems ixItem            If Left strItem  Len strSTART OF OBJECT    lt  gt  strSTART OF OBJECT Then             Err Raise vbObjectError  Description   Mal-formed list item  does not start with     amp  strSTART OF OBJECT  amp               End If            Only the last item will have a closing brace  see comment above          Dim bIsLastItem As Boolean  bIsLastItem   ixItem   UBound astrItems           If bIsLastItem Then             If Right strItem  Len strEND OF OBJECT    lt  gt  strEND OF OBJECT Then                 Err Raise vbObjectError  Description   Mal-formed list item  does not end with     amp  strEND OF OBJECT  amp                   End If         End If          Dim strContent  strContent   Mid strItem  1   Len strSTART OF OBJECT   Len strItem  - Len strSTART OF OBJECT  - IIf bIsLastItem  Len strEND OF OBJECT   0            ParseListOfObjects Add ParseObjectContent strContent       Next ixItem  End Function  Private Function ParseObjectContent ByVal strContent As String  As Scripting Dictionary      Set ParseObjectContent   New Scripting Dictionary     ParseObjectContent CompareMode   TextCompare        The object content will look something like            property   value    property   value                 although the value may not be in quotes  since numbers are not quoted        We can t assume that the property value won t contain a comma  so we can t just split the       string on the commas  but it s reasonably safe to assume that the value won t contain further quotes        and we re already assuming no sub-structure         We ll need to scan for commas while taking quoted strings into account       Dim ixPos As Long  ixPos   1     Do While ixPos  lt   Len strContent           Dim strRemainder As String            Find the opening quote for the name  names should always be quoted          Dim ixOpeningQuote As Long  ixOpeningQuote   InStr ixPos  strContent  strQUOTE           If ixOpeningQuote  lt   0 Then               The only valid reason for not finding a quote is if we re at the end  though white space is permitted              strRemainder   Trim Mid strContent  ixPos               If Len strRemainder    0 Then                 Exit Do             End If             Err Raise vbObjectError  Description   Mal-formed object  the object name does not start with a quote           End If            Now find the closing quote for the name  which we assume is the very next quote         Dim ixClosingQuote As Long  ixClosingQuote   InStr ixOpeningQuote   1  strContent  strQUOTE          If ixClosingQuote  lt   0 Then             Err Raise vbObjectError  Description   Mal-formed object  the object name does not end with a quote           End If          If ixClosingQuote - ixOpeningQuote - Len strQUOTE    0 Then             Err Raise vbObjectError  Description   Mal-formed object  the object name is blank           End If          Dim strName  strName   Mid strContent  ixOpeningQuote   Len strQUOTE   ixClosingQuote - ixOpeningQuote - Len strQUOTE              The next thing after the quote should be the colon          Dim ixNameValueSeparator As Long  ixNameValueSeparator   InStr ixClosingQuote   Len strQUOTE   strContent  strOBJECT PROPERTY NAME VALUE SEPARATOR           If ixNameValueSeparator  lt   0 Then             Err Raise vbObjectError  Description   Mal-formed object  missing     amp  strOBJECT PROPERTY NAME VALUE SEPARATOR  amp               End If            Check that there was nothing between the closing quote and the colon          strRemainder   Trim Mid strContent  ixClosingQuote   Len strQUOTE   ixNameValueSeparator - ixClosingQuote - Len strQUOTE            If Len strRemainder   gt  0 Then             Err Raise vbObjectError  Description   Mal-formed object  unexpected content between name and     amp  strOBJECT PROPERTY NAME VALUE SEPARATOR  amp               End If            What comes after the colon is the value  which may or may not be quoted  e g  numbers are not quoted             If the very next thing we see is a quote  then it s a quoted value  and we need to find the matching           closing quote while ignoring any commas inside the quoted value            If the next thing we see is NOT a quote  then it must be an unquoted value  and we can scan directly           for the next comma            Either way  we re looking for a quote or a comma  whichever comes first  or neither  in which case we           have the last - unquoted - value            ixOpeningQuote   InStr ixNameValueSeparator   Len strOBJECT PROPERTY NAME VALUE SEPARATOR   strContent  strQUOTE          Dim ixPropertySeparator As Long  ixPropertySeparator   InStr ixNameValueSeparator   Len strOBJECT PROPERTY NAME VALUE SEPARATOR   strContent  strLIST DELIMITER           If ixOpeningQuote  gt  0 And ixPropertySeparator  gt  0 Then               Only use whichever came first             If ixOpeningQuote  lt  ixPropertySeparator Then                 ixPropertySeparator   0             Else                 ixOpeningQuote   0             End If         End If          Dim strValue As String         Dim vValue As Variant          If ixOpeningQuote  lt   0 Then   it s not a quoted value              If ixPropertySeparator  lt   0 Then   there s no next value  this is the last one                 strValue   Trim Mid strContent  ixNameValueSeparator   Len strOBJECT PROPERTY NAME VALUE SEPARATOR                    ixPos   Len strContent    1             Else   this is not the last value                 strValue   Trim Mid strContent  ixNameValueSeparator   Len strOBJECT PROPERTY NAME VALUE SEPARATOR   ixPropertySeparator - ixNameValueSeparator - Len strOBJECT PROPERTY NAME VALUE SEPARATOR                    ixPos   ixPropertySeparator   Len strLIST DELIMITER              End If              vValue   ParseUnquotedValue strValue           Else   It is a quoted value                Find the corresponding closing quote  which should be the very next one              ixClosingQuote   InStr ixOpeningQuote   Len strQUOTE   strContent  strQUOTE               If ixClosingQuote  lt   0 Then                 Err Raise vbObjectError  Description   Mal-formed object  the value does not end with a quote               End If              strValue   Mid strContent  ixOpeningQuote   Len strQUOTE   ixClosingQuote - ixOpeningQuote - Len strQUOTE               vValue   ParseQuotedValue strValue                 Re-scan for the property separator  in case we hit one that was part of the quoted value             ixPropertySeparator   InStr ixClosingQuote   Len strQUOTE   strContent  strLIST DELIMITER               If ixPropertySeparator  lt   0 Then   this was the last value                    Check that there s nothing between the closing quote and the end of the text                 strRemainder   Trim Mid strContent  ixClosingQuote   Len strQUOTE                    If Len strRemainder   gt  0 Then                     Err Raise vbObjectError  Description   Mal-formed object  there is content after the last value                   End If                  ixPos   Len strContent    1              Else   this is not the last value                    Check that there s nothing between the closing quote and the property separator                 strRemainder   Trim Mid strContent  ixClosingQuote   Len strQUOTE   ixPropertySeparator - ixClosingQuote - Len strQUOTE                    If Len strRemainder   gt  0 Then                     Err Raise vbObjectError  Description   Mal-formed object  there is content after the last value                   End If                  ixPos   ixPropertySeparator   Len strLIST DELIMITER               End If          End If          ParseObjectContent Add strName  vValue      Loop  End Function  Private Function ParseUnquotedValue ByVal strValue As String  As Variant      If StrComp strValue  strNULL VALUE  vbTextCompare    0 Then         ParseUnquotedValue   Empty     ElseIf StrComp strValue  strTRUE VALUE  vbTextCompare    0 Then         ParseUnquotedValue   True     ElseIf StrComp strValue  strFALSE VALUE  vbTextCompare    0 Then         ParseUnquotedValue   False     ElseIf IsNumeric strValue  Then         ParseUnquotedValue   CDbl strValue      Else         Err Raise vbObjectError  Description   Mal-formed value  not null  true  false or a number       End If  End Function  Private Function ParseQuotedValue ByVal strValue As String  As Variant        Both dates and strings are quoted  we ll treat it as a date if it has the expected date format        Dates are in the form           2019-09-30T00 00 00     If strValue Like      -  -  T   00 00  Then           NOTE  we just want the date part         ParseQuotedValue   CDate Left strValue  Len      -  -           Else         ParseQuotedValue   strValue     End If  End Function   A simple test   Const strJSON As String        property1     foo      Dim oObjects As Collection  Set oObjects   Json ParseListOfObjects strJSON   MsgBox oObjects 1   property1     shows  foo

User · Answer

Microsoft  Because VBScript is a subset of Visual Basic for   Applications       The code below is derived from Codo s post should it also be helpful to have in class form  and usable as VBScript   class JsonParser       adapted from  http   stackoverflow com questions 6627652 parsing-json-in-excel-vba     private se     private sub Class Initialize         set se   CreateObject  MSScriptControl ScriptControl            se Language    JScript          se AddCode  function getValue jsonObj  valueName    return jsonObj valueName               se AddCode  function enumKeys jsonObj    var keys   new Array    for  var i in jsonObj    keys push i     return keys          end sub     public function Decode ByVal json          set Decode   se Eval       cstr json             end function      public function GetValue ByVal jsonObj  ByVal valueName          GetValue   se Run  getValue   jsonObj  valueName      end function      public function GetObject ByVal jsonObject  ByVal valueName          set GetObjet   se Run  getValue   jsonObject  valueName      end function      public function EnumKeys ByVal jsonObject          dim length  keys  obj  idx  key         set obj   se Run  enumKeys   jsonObject          length   GetValue obj   length           redim keys length - 1          idx   0         for each key in obj             keys idx    key             idx   idx   1         next         EnumKeys   keys     end function end class   Usage   set jp   new JsonParser set jo   jp Decode   value  true    keys   jp EnumKeys jo  value   jp GetValue jo   value

User · Answer

Another Regex based JSON parser  decode only   Private Enum JsonStep     jsonString     jsonNumber     jsonTrue     jsonFalse     jsonNull     jsonOpeningBrace     jsonClosingBrace     jsonOpeningBracket     jsonClosingBracket     jsonComma     jsonColon End Enum  Private regexp As Object  Private Function JsonStepName ByVal json step As JsonStep  As String     Select Case json step         Case jsonString  JsonStepName     STRING           Case jsonNumber  JsonStepName     NUMBER           Case jsonTrue  JsonStepName    true          Case jsonFalse  JsonStepName    false          Case jsonNull  JsonStepName    null          Case jsonOpeningBrace  JsonStepName                 Case jsonClosingBrace  JsonStepName                 Case jsonOpeningBracket  JsonStepName                 Case jsonClosingBracket  JsonStepName                 Case jsonComma  JsonStepName                 Case jsonColon  JsonStepName             End Select End Function  Private Function Unescape ByVal str As String  As String     Dim match As Object      str   Replace  str                   str   Replace  str                 str   Replace  str                 str   Replace  str    b   vbBack      str   Replace  str    f   vbFormFeed      str   Replace  str    n   vbCrLf      str   Replace  str    r   vbCr      str   Replace  str    t   vbTab      With regexp          Global   True          IgnoreCase   False          MultiLine   False          Pattern      u  0-9a-fA-F  4            For Each match In  Execute str              str   Replace  str  match value  ChrW  Val   amp H    match SubMatches 0     match FirstIndex   1  1          Next match     End With     Unescape   str End Function  Private Function ParseStep ByVal str As String                               ByRef index As Long                               ByRef value As Variant                               ByVal json step As JsonStep                               ByVal expected As Boolean  As Boolean     Dim match As Object      With regexp          Global   False          IgnoreCase   False          MultiLine   False         Select Case json step              Case jsonString   Pattern      s                      bfnrt    u 0-9a-fA-F  4       s               Case jsonString   Pattern      s                               bfnrt    u 0-9a-fA-F  4       s               Case jsonNumber   Pattern      s  -  0  1-9  d      d     eE  -    d     s               Case jsonTrue   Pattern      s  true  s               Case jsonFalse   Pattern      s  false  s               Case jsonNull   Pattern      s  null  s               Case jsonOpeningBrace   Pattern      s      s               Case jsonClosingBrace   Pattern      s      s               Case jsonOpeningBracket   Pattern      s      s               Case jsonClosingBracket   Pattern      s      s               Case jsonComma   Pattern      s      s               Case jsonColon   Pattern      s     s           End Select         Set match    Execute Mid  str  index       End With     If match Count  gt  0 Then         index   index   match 0  Length         Select Case json step             Case jsonString                 If match 0  SubMatches 1    Empty Then                     value   match 0  SubMatches 0                  Else                     value   Unescape match 0  SubMatches 0                   End If             Case jsonNumber  value   Val match 0  SubMatches 0               Case jsonTrue  value   True             Case jsonFalse  value   False             Case jsonNull  value   Null             Case Else  value   Empty         End Select         ParseStep   True     ElseIf expected Then         Err Raise 10001   ParseJson    Expecting    amp  JsonStepName json step   amp    at char    amp  index  amp          End If End Function  Private Function ParseValue ByRef str As String                                ByRef index As Long                                ByRef value As Variant                                ByVal expected As Boolean  As Boolean     ParseValue   True     If ParseStep str  index  value  jsonString  False  Then Exit Function     If ParseStep str  index  value  jsonNumber  False  Then Exit Function     If ParseObject str  index  value  False  Then Exit Function     If ParseArray str  index  value  False  Then Exit Function     If ParseStep str  index  value  jsonTrue  False  Then Exit Function     If ParseStep str  index  value  jsonFalse  False  Then Exit Function     If ParseStep str  index  value  jsonNull  False  Then Exit Function     ParseValue   False     If expected Then         Err Raise 10001   ParseJson    Expecting    amp  JsonStepName jsonString   amp        amp  JsonStepName jsonNumber   amp        amp  JsonStepName jsonTrue   amp        amp  JsonStepName jsonFalse   amp        amp  JsonStepName jsonNull   amp        amp  JsonStepName jsonOpeningBrace   amp     or    amp  JsonStepName jsonOpeningBracket   amp    at char    amp  index  amp          End If End Function  Private Function ParseObject ByRef str As String                                 ByRef index As Long                                 ByRef obj As Variant                                 ByVal expected As Boolean  As Boolean     Dim key As Variant     Dim value As Variant      ParseObject   ParseStep str  index  Empty  jsonOpeningBrace  expected      If ParseObject Then         Set obj   CreateObject  Scripting Dictionary           If ParseStep str  index  Empty  jsonClosingBrace  False  Then Exit Function         Do             If ParseStep str  index  key  jsonString  True  Then                 If ParseStep str  index  Empty  jsonColon  True  Then                     If ParseValue str  index  value  True  Then                         If IsObject value  Then                             Set obj Item key    value                         Else                             obj Item key    value                         End If                     End If                 End If             End If         Loop While ParseStep str  index  Empty  jsonComma  False          ParseObject   ParseStep str  index  Empty  jsonClosingBrace  True      End If End Function  Private Function ParseArray ByRef str As String                                ByRef index As Long                                ByRef arr As Variant                                ByVal expected As Boolean  As Boolean     Dim key As Variant     Dim value As Variant      ParseArray   ParseStep str  index  Empty  jsonOpeningBracket  expected      If ParseArray Then         Set arr   New Collection         If ParseStep str  index  Empty  jsonClosingBracket  False  Then Exit Function         Do             If ParseValue str  index  value  True  Then                 arr Add value             End If         Loop While ParseStep str  index  Empty  jsonComma  False          ParseArray   ParseStep str  index  Empty  jsonClosingBracket  True      End If End Function  Public Function ParseJson ByVal str As String  As Object     If regexp Is Nothing Then         Set regexp   CreateObject  VBScript RegExp       End If     If ParseObject str  1  ParseJson  False  Then Exit Function     If ParseArray str  1  ParseJson  False  Then Exit Function     Err Raise 10001   ParseJson    Expecting    amp  JsonStepName jsonOpeningBrace   amp    or    amp  JsonStepName jsonOpeningBracket   amp      End Function

[json] Parsing JSON in Excel VBA

Examples related to json

Examples related to excel

Examples related to parsing

Examples related to vba

Examples related to object