Comment récupérer les en-tetes JSON en VBA
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
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
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 !