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

Si vous voulez construire sur le dessus de ScriptControl vous pouvez ajouter quelques méthodes d'aide pour obtenir les informations requises. Le site JScriptTypeInfo est un peu malheureux : il contient toutes les informations pertinentes (comme vous pouvez le voir dans l'objet Regarder ) mais il semble impossible d'y accéder avec VBA. Cependant, le moteur Javascript peut nous aider :

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

Quelques notes :

• Si le JScriptTypeInfo instance fait référence à un objet Javascript, For Each ... Next ne fonctionnera pas. Cependant, cela fonctionne s'il fait référence à un tableau Javascript (cf. GetKeys fonction).
• Les propriétés d'accès dont le nom n'est connu qu'au moment de l'exécution, utilisent les fonctions GetProperty et GetObjectProperty .
• Le tableau Javascript fournit les propriétés length , 0 , Item 0 , 1 , Item 1 etc. Avec la notation par points de VBA ( jsonObject.property ), seule la propriété length est accessible et seulement si vous déclarez une variable appelée length avec toutes les lettres minuscules. Sinon, la casse ne correspond pas et le système ne le trouvera pas. Les autres propriétés ne sont pas valables en VBA. Il est donc préférable d'utiliser la propriété GetProperty fonction.
• Le code utilise une liaison précoce. Vous devez donc ajouter une référence à "Microsoft script Control 1.0".
• Vous devez appeler InitScriptEngine une fois avant d'utiliser les autres fonctions pour effectuer une initialisation de base.

Answer 2

MISE À JOUR 3 (24 Sep '17)

Vérifiez VBA-JSON-parser sur GitHub pour obtenir la dernière version et des exemples. Importation JSON.bas dans le projet VBA pour le traitement de JSON .

MISE À JOUR 2 (1er octobre 16)

Cependant, si vous souhaitez analyser JSON sur un Office 64 bits avec ScriptControl alors cette réponse peut vous aider à obtenir ScriptControl pour fonctionner sur 64 bits.

UPDATE (26 octobre '15)

Notez qu'un ScriptControl -Les approches basées sur l'utilisation d'ActiveX rendent le système vulnérable dans certains cas, car elles permettent un accès direct aux lecteurs (et à d'autres éléments) pour le code JS malveillant via ActiveX. Supposons que vous analysiez le JSON de la réponse du serveur web, comme suit JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}" . Après l'avoir évalué, vous trouverez le nouveau fichier créé. C:\Test.txt . Ainsi, l'analyse syntaxique JSON avec ScriptControl ActiveX n'est pas une bonne idée.

Pour essayer d'éviter cela, j'ai créé un analyseur JSON basé sur les RegEx. Objets {} sont représentés par des dictionnaires, ce qui permet d'utiliser les propriétés et les méthodes des dictionnaires : .Count , .Exists() , .Item() , .Items , .Keys . Matrices [] sont les tableaux VB conventionnels basés sur zéro, donc UBound() indique le nombre d'éléments. Voici le code avec quelques exemples d'utilisation :

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")) >= 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" & vbCrLf & 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" & vbCrLf & 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:" & vbCrLf & BeautifyJson(varItem)
    Next

    ' show the full structure starting from root element
    MsgBox "The full structure starting from root element:" & vbCrLf & 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 & "\source.json", -2)
    ParseJson strJsonString, varJson, strState
    If strState <> "Error" Then
        strResult = BeautifyJson(varJson)
        WriteTextFile strResult, strDesktop & "\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 = "<\d+(?:str|nam)>\:<\d+(?:str|num|obj|arr|cst)>"
            Tokenize objTokens, objRegEx, strContent, bMatched, "prp"
            .Pattern = "\{(?:<\d+prp>(?:,<\d+prp>)*)?\}"
            Tokenize objTokens, objRegEx, strContent, bMatched, "obj"
            .Pattern = "\[(?:<\d+(?:str|num|obj|arr|cst)>(?:,<\d+(?:str|num|obj|arr|cst)>)*)?\]"
            Tokenize objTokens, objRegEx, strContent, bMatched, "arr"
        Loop While bMatched
        .Pattern = "^<\d+(?:obj|arr)>$" ' 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 = "<" & objTokens.Count & strType & ">"
            bMatched = True
            With objMatch
                objTokens(strKey) = .Value
                strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey
                lngCopyIndex = .FirstIndex + .Length + 1
            End With
        Next
        strContent = strRes & 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 = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set varTransfer = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varTransfer
                Next
            Case "prp"
                .Pattern = "<\d+\w{3}>"
                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 = "<\d+\w{3}>"
                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(("&H" & 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 & "{}"
            Else
                strResult = strResult & "{" & vbCrLf
                lngIndent = lngIndent + lngStep
                arrKeys = varElement.Keys
                For lngIndex = 0 To UBound(arrKeys)
                    strResult = strResult & String(lngIndent, strIndent) & """" & arrKeys(lngIndex) & """" & ": "
                    BeautyTraverse strResult, lngIndent, varElement(arrKeys(lngIndex)), strIndent, lngStep
                    If Not (lngIndex = UBound(arrKeys)) Then strResult = strResult & ","
                    strResult = strResult & vbCrLf
                Next
                lngIndent = lngIndent - lngStep
                strResult = strResult & String(lngIndent, strIndent) & "}"
            End If
        Case Is >= vbArray
            If UBound(varElement) = -1 Then
                strResult = strResult & "[]"
            Else
                strResult = strResult & "[" & vbCrLf
                lngIndent = lngIndent + lngStep
                For lngIndex = 0 To UBound(varElement)
                    strResult = strResult & String(lngIndent, strIndent)
                    BeautyTraverse strResult, lngIndent, varElement(lngIndex), strIndent, lngStep
                    If Not (lngIndex = UBound(varElement)) Then strResult = strResult & ","
                    strResult = strResult & vbCrLf
                Next
                lngIndent = lngIndent - lngStep
                strResult = strResult & String(lngIndent, strIndent) & "]"
            End If
        Case vbInteger, vbLong, vbSingle, vbDouble
            strResult = strResult & varElement
        Case vbNull
            strResult = strResult & "Null"
        Case vbBoolean
            strResult = strResult & 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 & """" & strTemp & """"
    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

Une autre opportunité de ce parseur JSON RegEx est qu'il fonctionne sur Office 64 bits, où ScriptControl n'est pas disponible.

INITIAL (27 mai '15)

Voici une autre méthode pour analyser JSON en VBA, basée sur ScriptControl ActiveX, sans bibliothèques externes :

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' && type != 'Object') {return er;} else {return getdict(sample);}} catch(e) {return er;}}"
        .ExecuteStatement "function getdict(sample) {var type = gettype(sample); if(type != 'Array' && type != 'Object') return sample; var dict = new ActiveXObject('Scripting.Dictionary'); if(type == 'Array') {for(var key = 0; key < 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

Answer 3

Comme Json n'est rien d'autre que des chaînes de caractères, il peut être facilement manipulé si nous savons le manipuler de la bonne manière, quelle que soit la complexité de la structure. Je ne pense pas qu'il soit nécessaire d'utiliser une bibliothèque ou un convertisseur externe pour faire le travail. Voici un exemple où j'ai analysé des données json en utilisant la manipulation de chaînes.

Sub FetchData()
    Dim str As Variant, N&, R&

    With New XMLHTTP60
        .Open "GET", "https://oresapp.asicanada.net/ores.imis.services/api/member/?address=&callback=angular.callbacks._0&city=&companyName=&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

Answer 4

Pour analyser JSON en VBA sans ajouter une énorme bibliothèque à votre projet de classeur, j'ai créé la solution suivante. Elle est extrêmement rapide et stocke toutes les clés et valeurs dans un dictionnaire pour un accès facile :

Function ParseJSON(json$, Optional key$ = "obj") As Object
    p = 1
    token = Tokenize(json)
    Set dic = CreateObject("Scripting.Dictionary")
    If token(p) = "{" Then ParseObj key Else ParseArr key
    Set ParseJSON = dic
End Function

Function ParseObj(key$)
    Do: p = p + 1
        Select Case token(p)
            Case "]"
            Case "[":  ParseArr key
            Case "{"
                       If token(p + 1) = "}" Then
                           p = p + 1
                           dic.Add key, "null"
                       Else
                           ParseObj key
                       End If

            Case "}":  key = ReducePath(key): Exit Do
            Case ":":  key = key & "." & token(p - 1)
            Case ",":  key = ReducePath(key)
            Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
        End Select
    Loop
End Function

Function ParseArr(key$)
    Dim e&
    Do: p = p + 1
        Select Case token(p)
            Case "}"
            Case "{":  ParseObj key & ArrayID(e)
            Case "[":  ParseArr key
            Case "]":  Exit Do
            Case ":":  key = key & ArrayID(e)
            Case ",":  e = e + 1
            Case Else: dic.Add key & ArrayID(e), token(p)
        End Select
    Loop
End Function

Le code ci-dessus utilise quelques fonctions d'aide, mais la partie ci-dessus est la plus importante.

La stratégie utilisée ici consiste à employer un tokenizer récursif. J'ai trouvé cela suffisamment intéressant pour écrire un article sur cette solution sur Medium. Il explique les détails.

Voici la liste complète (mais étonnamment courte) du code, y compris toutes les fonctions d'aide :

'-------------------------------------------------------------------
' VBA JSON Parser
'-------------------------------------------------------------------
Option Explicit
Private p&, token, dic
Function ParseJSON(json$, Optional key$ = "obj") As Object
    p = 1
    token = Tokenize(json)
    Set dic = CreateObject("Scripting.Dictionary")
    If token(p) = "{" Then ParseObj key Else ParseArr key
    Set ParseJSON = dic
End Function
Function ParseObj(key$)
    Do: p = p + 1
        Select Case token(p)
            Case "]"
            Case "[":  ParseArr key
            Case "{"
                       If token(p + 1) = "}" Then
                           p = p + 1
                           dic.Add key, "null"
                       Else
                           ParseObj key
                       End If

            Case "}":  key = ReducePath(key): Exit Do
            Case ":":  key = key & "." & token(p - 1)
            Case ",":  key = ReducePath(key)
            Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
        End Select
    Loop
End Function
Function ParseArr(key$)
    Dim e&
    Do: p = p + 1
        Select Case token(p)
            Case "}"
            Case "{":  ParseObj key & ArrayID(e)
            Case "[":  ParseArr key
            Case "]":  Exit Do
            Case ":":  key = key & ArrayID(e)
            Case ",":  e = e + 1
            Case Else: dic.Add key & ArrayID(e), token(p)
        End Select
    Loop
End Function
'-------------------------------------------------------------------
' Support Functions
'-------------------------------------------------------------------
Function Tokenize(s$)
    Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"
    Tokenize = RExtract(s, Pattern, True)
End Function
Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)
  Dim c&, m, n, v
  With CreateObject("vbscript.regexp")
    .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 = """""" Then v(c) = n.submatches(0)
      Next
    End If
  End With
  RExtract = v
End Function
Function ArrayID$(e)
    ArrayID = "(" & e & ")"
End Function
Function ReducePath$(key$)
    If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1)
End Function
Function ListPaths(dic)
    Dim s$, v
    For Each v In dic
        s = s & v & " --> " & dic(v) & vbLf
    Next
    Debug.Print s
End Function
Function GetFilteredValues(dic, match)
    Dim c&, i&, 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&, i&, j&, 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("ADODB.Stream")
        .Charset = "utf-8"
        .Open
        .LoadFromFile f
        OpenTextFile = .ReadText
    End With
End Function

Answer 5

Plus simplement, vous pouvez utiliser array.myitem(0) en code VB.

ma réponse complète ici parse et stringify (serialize)

Utiliser l'objet 'this' en js

ScriptEngine.AddCode "Object.prototype.myitem=function( i ) { return this[i] } ; "

Ensuite, vous pouvez aller 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