Comment récupérer les en-tetes JSON en VBA

94jsonconverter.zip (8.77 Ko)

Salut à tous,

J'ai besoin d'aide pour écrire le code qui permettrait d'extraire d'un fichier JSON quelconque ses en-têtes vers un Array pour ensuite pouvoir les traiter les Item

J'arrive facilement à travailler avec un JSON en connaissant sa structure, puis en utilisant le module "JsonConverter", je crée mes en-têtes de colonnes et ensuite je remplis mes lignes sans problèmes. Je cherche à pouvoir travailler avec n'importe quelle structure de JSON.

Je récupère les items avec ce code:

Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "http://jsonplaceholder.typicode.com/users", False
http.send
Set JSON = ParseJson(http.responsetext)
For Each Item In JSON

Next

Peut-etre qu'un partie de la réponse se trouve dans le JsonConverter, mais je ne suis pas un expert en programmation alors je me perds facilement...

Toute aide sera appréciée

Merci d'avance

Bonjour et bienvenue,

Trop facile!

Dans une feuille neuve, on place en A1 l'adresse d'un json distant, et on lance le code "Recup_cles_json" :

Option Explicit

' ***********************************************************************
' *****                                                             *****
' *****        CODE PierreP56 : http://tatiak.canalblog.com/        *****
' *****                                                             *****
' ***********************************************************************

Sub Recup_cles_json()
Dim Ndf As String, S As String, T As Variant

    With ActiveSheet
        If Not .Range("A1").Value = "" Then
            S = Json_txt(.Range("A1").Value)
            T = GetKeys(S)
            .Range("A2:A2000").ClearContents
            .Range("A2").Resize(UBound(T, 1)) = Application.Transpose(T)
        End If
    End With
End Sub

Function Json_txt(Site As String) As String
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", Site, False
        .send
        Json_txt = .responsetext
    End With
End Function

Function GetKeys(Sttk As String) As String()
Dim T() As String, Clefs() As String, S As String
Dim lg As Long, lg2 As Long, idx As Long, i As Long, j As Long
Dim Present As Boolean

    T = Split(Sttk, """:")
    lg = UBound(T) - 1
    idx = 0
    ReDim Clefs(idx)
    For i = 0 To lg
        Present = False
        S = Right(T(i), InStr(StrReverse(T(i)), """") - 1)
        lg2 = UBound(Clefs)
        For j = 0 To lg2
            If S = Clefs(j) Then
                Present = True
                Exit For
            End If
        Next j

        If Not Present And Not S = "" Then
            ReDim Preserve Clefs(idx)
            Clefs(idx) = S
            idx = idx + 1
        End If
    Next i
    GetKeys = Clefs
End Function

A noter dans cette liste, la hiérarchisation des clés n'apparait pas.

Pierre

Bravo Pierre,

un coup de split = simple et efficace

on peut le faire aussi via ...

    Set ScriptEngine = CreateObject("MSScriptControl.ScriptControl")
    ScriptEngine.Language = "JScript"
    ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "

Voici "tout en un" un décodage json qui te donnera les clés, les niveaux (donc la hiérarchisation), et les valeurs.

Je ne sais plus trop où j'ai récupéré des petits bouts de programme que j'ai fini par assembler et simplifier. C'est encore une version proto "vX".

Option Explicit
Public ScriptEngine As Object
Dim ligne% ' pour alimenter la feuille

Public Sub InitScriptEngine(ok As Boolean)
    Set ScriptEngine = CreateObject("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 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 routineJSON(JsonObject As Object, niveau As Integer, Optional parent As String = "")
    Dim Keys() As String
    Dim Value As Variant
    Dim SousObject As Object
    Dim i As Variant

    Keys = GetKeys(JsonObject)

    For i = LBound(Keys) To UBound(Keys)
        Value = GetProperty(JsonObject, Keys(i))
        On Error Resume Next ' teste le cas d'un objet et détermine si non en cas d'erreur !
        Set SousObject = GetObjectProperty(JsonObject, Keys(i))
        If Err.Number Then ' c'est une valeur
            ' Debug.Print niveau & " - " & parent & "." & Keys(i) & " = " & Value
            Cells(ligne, niveau) = Keys(i): Cells(ligne, niveau + 1) = Value: ligne = ligne + 1
        Else ' c'est un objet
            ' Debug.Print niveau & " - " & Keys(i) & " : "
            Cells(ligne, niveau) = Keys(i): Cells(ligne, niveau + 1) = "*": ligne = ligne + 1
            parent = parent & "." & Keys(i): niveau = niveau + 1
            routineJSON SousObject, niveau, parent
            parent = Left(parent, Len(parent) - InStr(StrReverse(parent), ".")): niveau = niveau - 1
        End If
    Next

End Sub

Public Sub decrypterJSON()
Dim JsonString As String
Dim JsonObject As Object, http As Object

    [A1].CurrentRegion.Offset(1, 0).ClearContents

' origine des informations
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", [A1], False
    http.send
    JsonString = http.responsetext

' decodage
    InitScriptEngine True
    Set JsonObject = ScriptEngine.Eval("(" + CStr(JsonString) + ")")
    ligne = 2
    routineJSON JsonObject, 1

End Sub
157decoderjson-vx.xlsm (27.45 Ko)

Salut Steelson ,

Je pensais bien te retrouver sur ce sujet!

Alors j'y vais aussi de ma proposition qui intègre cette fois-ci les niveaux d'imbrication. Mais uniquement les clés.

Toujours avec le bon vieux Split!

Et toujours avec l'adresse du json en A1 de la feuille courante.

Pierre

Option Explicit

' ***********************************************************************
' *****                                                             *****
' *****        CODE PierreP56 : http://tatiak.canalblog.com/        *****
' *****                                                             *****
' ***********************************************************************

Sub Recup_Cles_json()
Dim Ndf As String, S As String, T As Variant

    With ActiveSheet
        If Not .Range("A1").Value = "" Then
            S = Json_txt(.Range("A1").Value)
            T = GetKeys_Niveaux(S)

            .Range("A2:A2000").ClearContents
            .Range("A2").Resize(UBound(T, 2), UBound(T, 1)) = Application.Transpose(T)
        End If
    End With
End Sub

Function Json_txt(Site As String) As String
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", Site, False
        .send
        Json_txt = .responsetext
    End With
End Function

Function GetKeys_Niveaux(Sttk As String) As Variant
Dim T1() As String, T2() As String, T3() As String
Dim i As Long, j As Long, k As Long, m As Long, idx As Long
Dim clefs As Variant, S As String
Dim Present As Boolean, Niv As Byte

    Niv = 0
    idx = 1
    ReDim clefs(1 To 2, 1 To idx)
    T1 = Split(Sttk, "{")
    For i = 0 To UBound(T1)
        T2 = Split(T1(i), "}")
        If i > 0 Then Niv = Niv + 1
        For j = 0 To UBound(T2)
            If j > 0 Then Niv = Niv - 1
            T3 = Split(T2(j), """:")
            For k = 0 To UBound(T3)
                If InStr(StrReverse(T3(k)), """") > 1 Then
                    S = Right(T3(k), InStr(StrReverse(T3(k)), """") - 1)
                    If Not Right(S, 1) = " " Then
                        Present = False
                        For m = 1 To UBound(clefs, 2)
                            If S = clefs(1, m) Then
                                Present = True
                                Exit For
                            End If
                        Next m
                        If Not Present And Not S = "" Then
                            clefs(1, idx) = S
                            clefs(2, idx) = Niv
                            idx = idx + 1
                            ReDim Preserve clefs(1 To 2, 1 To idx)
                        End If
                    End If
                End If
            Next k
        Next j
    Next i
    GetKeys_Niveaux = clefs
End Function

@Pierre

On ne change pas une équipe qui gagne !!

Mais quand même, les rôles sont un peu inversés ... moi l'adepte du split à tout va et toi le pape du ScriptControl !

J'ai un petit soucis avec ta méthode quand 2 clés à 2 niveaux différents ont la même valeur. Car il existe aussi un name sous company

capture d ecran 388

Bien vu!

Il suffit alors de modifier une ligne :

For m = 1 To UBound(clefs, 2)
    If S = clefs(1, m) And Niv = clefs(2, m) Then
        Present = True
        Exit For

Re-bonjour à tous,

Pour compléter le résultat de la recherche, il me semble intéressant aussi de retourner le type de donnée pour chaque clé. Car la "valeur" contenue par une clé peut être du texte, une valeur numérique, un tableau, ou un "parent" (ou ?). Et le traitement ultérieur sera donc différent selon ce type de donnée.

Le code suivant retourne donc un tableau avec la clé, son niveau hiérarchique et le type de données.

(et avec un visuel hiérarchisé à droite de la liste à partir de la colonne E, pour-faire-comme-Steelson )

Toujours avec l'adresse en A1

Option Explicit

' ***********************************************************************
' *****                                                             *****
' *****        CODE PierreP56 : http://tatiak.canalblog.com/        *****
' *****                                                             *****
' ***********************************************************************

Sub Recup_Cles_json()
Dim Ndf As String, S As String, T As Variant

    With ActiveSheet
        If Not .Range("A1").Value = "" Then
            S = Json_txt(.Range("A1").Value)
            T = GetKeys_Niveaux(S)

            .Range("A2:T2000").ClearContents
            .Range("A2").Resize(UBound(T, 2), UBound(T, 1)) = Application.Transpose(T)
        End If
    End With
End Sub

Function Json_txt(Site As String) As String
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", Site, False
        .send
        Json_txt = .responsetext
    End With
End Function

Function GetKeys_Niveaux(Sttk As String) As Variant
Dim T1() As String, T2() As String, T3() As String
Dim i As Long, j As Long, k As Long, m As Long, idx As Long
Dim clefs As Variant, S As String, Ty As String
Dim Present As Boolean, Niv As Byte

    Niv = 0
    idx = 1
    ReDim clefs(1 To 20, 1 To idx)
    T1 = Split(Sttk, "{")
    For i = 0 To UBound(T1)
        T2 = Split(T1(i), "}")
        If i > 0 Then Niv = Niv + 1
        For j = 0 To UBound(T2)
            If j > 0 Then Niv = Niv - 1
            T3 = Split(T2(j), """:")
            For k = 0 To UBound(T3)
                If InStr(StrReverse(T3(k)), """") > 1 Then
                    S = Right(T3(k), InStr(StrReverse(T3(k)), """") - 1)
                    If Not Right(S, 1) = " " Then
                        Present = False
                        For m = 1 To UBound(clefs, 2)
                            If S = clefs(1, m) And Niv = clefs(2, m) Then
                                Present = True
                                Exit For
                            End If
                        Next m
                        If Not Present And Not S = "" Then
                            clefs(1, idx) = S
                            clefs(2, idx) = Niv
                            Ty = Mid(T2(j), InStr(T2(j), S) + Len(S) + 3, 1)
                            Select Case Ty
                                Case "": clefs(3, idx) = "Parent"
                                Case "[": clefs(3, idx) = "Array"
                                Case """": clefs(3, idx) = "Text"
                                Case Else: clefs(3, idx) = "Numeric"
                            End Select
                            clefs(4 + Niv, idx) = S
                            idx = idx + 1
                            ReDim Preserve clefs(1 To 20, 1 To idx)
                        End If
                    End If
                End If
            Next k
        Next j
    Next i
    GetKeys_Niveaux = clefs
End Function

@Pierre

Bonjour

On a dû perdre pahu ! ?

J'au une question pour toi Pierre :

si je prototype afin d'accéder directement aux informations par

    Set ScriptEnginePrototype = CreateObject("ScriptControl")
    ScriptEnginePrototype.Language = "JScript"
    ScriptEnginePrototype.AddCode "Object.prototype.numero=function( i ) { return this[i] } ; "

J'ai un soucis d'accès quand la clé est "name" car excel transforme en Name et le prototypage est sensible à la casse.

Ce que je fais dans ce cas, est que je remplace "name" dans le json par "nom".

Idem pour "email" !

Y a t'il une solution pour ne pas dénaturer le json avant traitement ?

Bonjour Steelson,

Je ne sais pas si je réponds bien à la question, mais pour toutes les clés ayant des intitulés identiques à des mots du vocabulaire vba, pour la lecture il suffit d'utiliser un CallByName. Par exemple :

    For Each elem In DataSet
        Debug.Print VBA.CallByName(DataSet, "name", VbGet)
        ' ... etc ...

Pierre

OK, j'étais en train d'essayer en effet cette méthode !

Il faut bien sûr que l'objet DataSet lui corresponde, dans le cas présent "name" s'adresse à 2 niveaux du json

merci pour ta réponse

Pour compléter le résultat de la recherche, il me semble intéressant aussi de retourner le type de donnée pour chaque clé. Car la "valeur" contenue par une clé peut être du texte, une valeur numérique, un tableau, ou un "parent" (ou ?).

Excellente idée ... attention, pour avoir beaucoup pratiqué le json dans des sites web + javascript, un même identifiant au même niveau pourrait être tantôt texte tantôt array !

Exemple des codes postaux en France qui peuvent concerner une seule commune (texte), ou plusieurs (array).

Le cas est rare néanmoins (javascript l'absorbe sans problème) car il conviendrait dans ce cas de faire un array à une dimension pour une commune seule !

Rechercher des sujets similaires à "comment recuperer tetes json vba"