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

Y compris Power BI, Power Query et toute autre question en lien avec Excel
p
pahu
Nouveau venu
Nouveau venu
Messages : 1
Inscrit le : 16 janvier 2019
Version d'Excel : Office 365

Message par pahu » 16 janvier 2019, 17:14

JsonConverter.zip
Module JSON
(8.77 Kio) Téléchargé 8 fois
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
Avatar du membre
pierrep56
Membre dévoué
Membre dévoué
Messages : 814
Appréciations reçues : 78
Inscrit le : 18 juin 2014
Version d'Excel : 2016

Message par pierrep56 » 17 janvier 2019, 14:43

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
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 10'768
Appréciations reçues : 523
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR

Message par Steelson » 17 janvier 2019, 14:57

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; } "

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 10'768
Appréciations reçues : 523
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR

Message par Steelson » 17 janvier 2019, 17:02

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
decoderJSON vX.xlsm
(27.45 Kio) Téléchargé 8 fois

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
pierrep56
Membre dévoué
Membre dévoué
Messages : 814
Appréciations reçues : 78
Inscrit le : 18 juin 2014
Version d'Excel : 2016

Message par pierrep56 » 17 janvier 2019, 17:56

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
1 membre du forum aime ce message.
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 10'768
Appréciations reçues : 523
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR

Message par Steelson » 18 janvier 2019, 04:42

@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’écran (388).png
1 membre du forum aime ce message.

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
pierrep56
Membre dévoué
Membre dévoué
Messages : 814
Appréciations reçues : 78
Inscrit le : 18 juin 2014
Version d'Excel : 2016

Message par pierrep56 » 18 janvier 2019, 11:05

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
Avatar du membre
pierrep56
Membre dévoué
Membre dévoué
Messages : 814
Appréciations reçues : 78
Inscrit le : 18 juin 2014
Version d'Excel : 2016

Message par pierrep56 » 18 janvier 2019, 11:51

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 :lol: )

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
1 membre du forum aime ce message.
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 10'768
Appréciations reçues : 523
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR

Message par Steelson » 19 janvier 2019, 09:24

@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 ?

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
pierrep56
Membre dévoué
Membre dévoué
Messages : 814
Appréciations reçues : 78
Inscrit le : 18 juin 2014
Version d'Excel : 2016

Message par pierrep56 » 19 janvier 2019, 09:42

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
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message