Analyse de JSON dans Excel VBA

Question

J'ai le même problème que dans Excel VBA : Boucle d'objets JSON analysés mais je ne trouve aucune solution. Mon JSON contient des objets imbriqués, donc les solutions proposées comme VBJSON et vba-json ne fonctionnent pas pour moi. J'ai également corrigé l'un d'entre eux pour qu'il fonctionne correctement, mais le résultat était un dépassement de la pile d'appels en raison de trop de récursions de la fonction doProcess.

La meilleure solution semble être la fonction jsonDecode vue dans le post original. Elle est très rapide et très efficace ; ma structure d'objet est toute là dans un objet VBA générique de type JScriptTypeInfo.

Le problème à ce stade est que je ne peux pas déterminer quelle sera la structure des objets, par conséquent, je ne connais pas à l'avance les clés qui résideront dans chaque objet générique. J'ai besoin de faire une boucle dans l'objet VBA générique pour obtenir les clés/propriétés.

Si ma fonction javascript d'analyse syntaxique pouvait déclencher une fonction ou un sous-programme VBA, ce serait excellent.

Answer 1

Cela fonctionne pour moi sous Excel et un grand fichier JSON en utilisant une requête JSON traduite en forme native. https://github.com/VBA-tools/VBA-JSON Je suis capable d'analyser un nœud comme "item.something" et d'obtenir une valeur en utilisant une commande simple :

MsgBox Json("item")("something")

Ce qui est bien.

Answer 2

Microsoft : Parce que VBScript est un sous-ensemble de Visual Basic for Applications,...

Le code ci-dessous est dérivé du post de Codo ; il serait également utile de l'avoir sous forme de classe, et utilisable en tant que 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

Utilisation :

set jp = new JsonParser
set jo = jp.Decode("{value: true}")
keys = jp.EnumKeys(jo)
value = jp.GetValue(jo, "value")

Answer 3

Merci beaucoup Codo.

Je viens de mettre à jour et de compléter ce que vous avez fait à :

• sérialise le json (j'en ai besoin pour injecter le json dans un document de type texte)

• ajouter, supprimer et mettre à jour un nœud (qui sait)

  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

Answer 4

Un autre analyseur JSON basé sur Regex (décodage seulement)

Option Explicit

Private Enum JsonStep
    jstUnexpected
    jstString
    jstNumber
    jstTrue
    jstFalse
    jstNull
    jstOpeningBrace
    jstClosingBrace
    jstOpeningBracket
    jstClosingBracket
    jstComma
    jstColon
    jstWhitespace
End Enum

Private gobjRegExpJsonStep As Object
Private gobjRegExpUnicodeCharacters As Object
Private gobjTokens As Object
Private k As Long

Private Function JsonStepName(ByRef jstStep As JsonStep) As String
    Select Case jstStep
        Case jstString: JsonStepName = "'STRING'"
        Case jstNumber: JsonStepName = "'NUMBER'"
        Case jstTrue: JsonStepName = "true"
        Case jstFalse: JsonStepName = "false"
        Case jstNull: JsonStepName = "null"
        Case jstOpeningBrace: JsonStepName = "'{'"
        Case jstClosingBrace: JsonStepName = "'}'"
        Case jstOpeningBracket: JsonStepName = "'['"
        Case jstClosingBracket: JsonStepName = "']'"
        Case jstComma: JsonStepName = "','"
        Case jstColon: JsonStepName = "':'"
        Case jstWhitespace: JsonStepName = "'WHITESPACE'"
        Case Else: JsonStepName = "'UNEXPECTED'"
    End Select
End Function

Private Function Unescape(ByVal strText As String) As String
    Dim objMatches As Object
    Dim i As Long

    strText = Replace$(strText, "\""", """")
    strText = Replace$(strText, "\\", "\")
    strText = Replace$(strText, "\/", "/")
    strText = Replace$(strText, "\b", vbBack)
    strText = Replace$(strText, "\f", vbFormFeed)
    strText = Replace$(strText, "\n", vbCrLf)
    strText = Replace$(strText, "\r", vbCr)
    strText = Replace$(strText, "\t", vbTab)
    If gobjRegExpUnicodeCharacters Is Nothing Then
        Set gobjRegExpUnicodeCharacters = CreateObject("VBScript.RegExp")
        With gobjRegExpUnicodeCharacters
            .Global = True
            .Pattern = "\\u([0-9a-fA-F]{4})"
        End With
    End If
    Set objMatches = gobjRegExpUnicodeCharacters.Execute(strText)
    For i = 0 To objMatches.Count - 1
        With objMatches(i)
            strText = Replace$(strText, .Value, ChrW$(Val("&H" + .SubMatches(0))), , 1)
        End With
    Next i
    Unescape = strText
End Function

Private Sub Tokenize(ByRef strText As String)
    If gobjRegExpJsonStep Is Nothing Then
        Set gobjRegExpJsonStep = CreateObject("VBScript.RegExp")
        With gobjRegExpJsonStep
            .Pattern = "(""((?:[^\\""]+|\\[""\\/bfnrt]|\\u[0-9a-fA-F]{4})*)""|" & _
                        "(-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][-+]?\d+)?)|" & _
                        "(true)|" & _
                        "(false)|" & _
                        "(null)|" & _
                        "(\{)|" & _
                        "(\})|" & _
                        "(\[)|" & _
                        "(\])|" & _
                        "(\,)|" & _
                        "(:)|" & _
                        "(\s+)|" & _
                        "(.+?))"
            .Global = True
        End With
    End If
    Set gobjTokens = gobjRegExpJsonStep.Execute(strText)
End Sub

Private Function ErrorMessage(ByRef vntExpecting As Variant) As String
    Dim lngLB As Long
    Dim lngUB As Long
    Dim i As Long
    Dim jstJsonStep As JsonStep
    Dim strResult As String

    If Rank(vntExpecting) = 1 Then
        lngLB = LBound(vntExpecting)
        lngUB = UBound(vntExpecting)
        If lngLB <= lngUB Then
            strResult = "Expecting "
            For i = lngLB To lngUB
                jstJsonStep = vntExpecting(i)
                If i > lngLB Then
                    If i < lngUB Then
                        strResult = strResult & ", "
                    Else
                        strResult = strResult & " or "
                    End If
                End If
                strResult = strResult & JsonStepName(jstJsonStep)
            Next i
        End If
    End If
    If strResult = "" Then
        strResult = "Unexpected error"
    End If
    If gobjTokens.Count > 0 Then
        If k < gobjTokens.Count Then
            strResult = strResult & " at position " & (gobjTokens(k).FirstIndex + 1) & "."
        Else
            strResult = strResult & " at EOF."
        End If
    Else
        strResult = strResult & " at position 1."
    End If
    ErrorMessage = strResult
End Function

Private Function ParseStep(ByRef vntValue As Variant) As JsonStep
    Dim i As Long

    k = k + 1
    If k >= gobjTokens.Count Then
        vntValue = Empty
        Exit Function
    End If
    With gobjTokens(k)
        For i = 1 To 12
            If Not IsEmpty(.SubMatches(i)) Then
                ParseStep = i
                Exit For
            End If
        Next i
        Select Case ParseStep
            Case jstString
                vntValue = Unescape(.SubMatches(1))
            Case jstNumber
                vntValue = Val(.SubMatches(2))
            Case jstTrue
                vntValue = True
            Case jstFalse
                vntValue = False
            Case jstNull
                vntValue = Null
            Case jstWhitespace
                ParseStep = ParseStep(vntValue)
            Case Else
                vntValue = Empty
        End Select
    End With
End Function

Private Function ParseObject(ByRef vntObject As Variant) As Boolean
    Dim strKey As String
    Dim vntValue As Variant
    Dim objResult As Object

    Set objResult = CreateObject("Scripting.Dictionary")
    Do
        Select Case ParseStep(strKey)
            Case jstString
                If Not ParseStep(Empty) = jstColon Then
                    LogError "ParseObject", ErrorMessage(Array(jstColon))
                    Exit Function
                End If
                Select Case ParseStep(vntValue)
                    Case jstString, jstNumber, jstTrue, jstFalse, jstNull
                        objResult.Item(strKey) = vntValue
                    Case jstOpeningBrace
                        If ParseObject(vntValue) Then
                            Set objResult.Item(strKey) = vntValue
                        End If
                    Case jstOpeningBracket
                        If ParseArray(vntValue) Then
                            Set objResult.Item(strKey) = vntValue
                        End If
                    Case Else
                        LogError "ParseObject", ErrorMessage(Array(jstString, jstNumber, jstTrue, jstFalse, jstNull, jstOpeningBrace, jstOpeningBracket))
                        Exit Function
                End Select
                Select Case ParseStep(Empty)
                    Case jstComma
                        'Do nothing
                    Case jstClosingBrace
                        Set vntObject = objResult
                        ParseObject = True
                        Exit Function
                    Case Else
                        LogError "ParseObject", ErrorMessage(Array(jstComma, jstClosingBrace))
                        Exit Function
                End Select
            Case jstClosingBrace
                Set vntObject = objResult
                ParseObject = True
                Exit Function
            Case Else
                LogError "ParseObject", ErrorMessage(Array(jstString, jstClosingBrace))
                Exit Function
        End Select
    Loop While True
End Function

Private Function ParseArray(ByRef vntArray As Variant) As Boolean
    Dim vntValue As Variant
    Dim colResult As Collection

    Set colResult = New Collection
    Do
        Select Case ParseStep(vntValue)
            Case jstString, jstNumber, jstTrue, jstFalse, jstNull
                colResult.Add vntValue
            Case jstOpeningBrace
                If ParseObject(vntArray) Then
                    colResult.Add vntArray
                End If
            Case jstOpeningBracket
                If ParseArray(vntArray) Then
                    colResult.Add vntArray
                End If
            Case jstClosingBracket
                Set vntArray = colResult
                ParseArray = True
                Exit Function
            Case Else
                LogError "ParseArray", ErrorMessage(Array(jstString, jstNumber, jstTrue, jstFalse, jstNull, jstOpeningBrace, jstOpeningBracket, jstClosingBracket))
                Exit Function
        End Select
        Select Case ParseStep(Empty)
            Case jstComma
                'Do nothing
            Case jstClosingBracket
                Set vntArray = colResult
                ParseArray = True
                Exit Function
            Case Else
                LogError "ParseArray", ErrorMessage(Array(jstComma, jstClosingBracket))
                Exit Function
        End Select
    Loop While True
End Function

Public Function ParseJson(ByRef strText As String, _
                          ByRef objJson As Object) As Boolean
    Tokenize strText
    k = -1
    Select Case ParseStep(Empty)
        Case jstOpeningBrace
            ParseJson = ParseObject(objJson)
        Case jstOpeningBracket
            ParseJson = ParseArray(objJson)
        Case Else
            LogError "ParseJson", ErrorMessage(Array(jstOpeningBrace, jstOpeningBracket))
    End Select
End Function

Answer 5

Deux petites contributions à Codo La réponse de la Commission :

' "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

Donc maintenant je peux faire des trucs comme :

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