VBA interrogation critères multiples base SIRENE
Ah, mais c'est intéressant cette notion de "json gigogne"!!
Tu as parfaitement raison! Et c'est là la place des \
En fait dans ce "prix de l'essence" ce champs "timetable" qui contient des \, si on le considère comme "json gigogne" et si on le lit au travers d'un ScriptControl.eval, on obtient directement un json "propre" (sans slash) qu'on traite alors comme n'importe quel sous-ensemble!
Dans cet exemple de l'essence, on a donc des horaires qui devraient correspondre aux ouvertures-fermetures des stations
Ca donne un truc genre
Set Fld = VBA.CallByName(elem, "fields", VbGet)
T(i, 1) = Fld.city
' ...
Set TmTble = Sous_Obj(Fld.timetable)
T(i, 8) = VBA.CallByName(TmTble.Lundi, "ouvert", VbGet) & "|" & _
VBA.CallByName(TmTble.Lundi, "ouverture", VbGet) & "|" & _
VBA.CallByName(TmTble.Lundi, "fermeture", VbGet)
' ...Avec une fonction toute simple :
Function Sous_Obj(S As String) As Object
Dim ScrC As Object
Set ScrC = CreateObject("MSScriptControl.ScriptControl")
ScrC.Language = "JScript"
Set Sous_Obj = ScrC.Eval("(" & S & ")")
End FunctionTa notion de "json gigogne" est juste parfaite!! Bien vu Steelson !
Pierre
Et je viens de voir ton code qui est encore plus efficace que le mien!
Bravo!!
PS : ajout version avec code amélioré
Ben oui, on se forme mutuellement (moi l'inconditionnel des split je finis par me mettre au VBA.CallByName bien que parfois ce soit plus ardu !).
Bonjour Pierre,
...de cet object on peut lire directos les éléments de niveau 1 avec un VBA.CallByName
je vais voir aussi une autre voie qui serait d'utiliser cette fonction
.AddCode "Object.prototype.item=function( i ) { return this[i] } ; "de ce fait on pourrait peut-être accéder en une seule étape à la valeur souhaitée ...
Michel
Sans utiliser VBA.CallByName ...
Public Const BASE_SIRENE = "https://data.opendatasoft.com/api/records/1.0/search/?dataset=sirene_v3%40public&q="
Sub Lire_sirene()
Dim Url As String, Nb As Integer, idx As Integer
Dim Brut As Object, Elem As Object
Dim T As Variant
On Error Resume Next
With Sheets("Sirene")
.Range("A6:L1000").ClearContents
Url = BASE_SIRENE & .Range("A4").Value
Set Brut = Obj_Rcdst(Url)
Nb = Brut.nhits
ReDim T(1 To Nb, 1 To 10)
idx = 1
For Each Elem In Brut.records
With Elem.champs ' en remplacement de fields dont excel met invariablement une majuscule !
T(idx, 1) = .enseigne1etablissement
T(idx, 2) = .adresseetablissement
T(idx, 3) = .denominationunitelegale
T(idx, 4) = .regionetablissement
End With
idx = idx + 1
Next Elem
.Range("B7").Resize(UBound(T, 1), UBound(T, 2)) = T
End With
Set Brut = Nothing
End Sub
Function Obj_Rcdst(Url As String) As Object
Dim ScrC As Object
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", Url, False
.send
Set ScrC = CreateObject("MSScriptControl.ScriptControl")
ScrC.Language = "JScript"
Set Obj_Rcdst = ScrC.Eval("(" & Replace(.responseText, "fields", "champs") & ")")
End With
End FunctionJ'ai juste parfois un soucis avec des mots qu'excel met en majuscule (et ça coince !), comme name, address, fields etc.
Bonjour à tous, Salut Steelson,
Alors dans le genre, je peux proposer ceci :
.Language = "JScript"
.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
.AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "Ici, pour ce json dont on ne connait pas le jeu de clé d'avance (puisque ça fluctue dans le temps par définition -> données météo actualisées), on injecte 2 fonctions javascript pour récupérer les clés d'une part et les contenus de l'autre.
Ca permet d'avoir un code de lecture simple :
For i = 5 To UBound(Keys)
Set Data = GetObjectProperty(Obj, Keys(i))
T(i + 2, 1) = Keys(i)
T(i + 2, 2) = Data.pression.niveau_de_la_mer
T(i + 2, 3) = Data.temperature.sol
T(i + 2, 4) = VBA.CallByName(Data.vent_moyen, "10m", VbGet)
Next i(rq : affichage de quelques données brutes du site ...)
MAIS ça n'exclut pas le recours obligatoire à VBA.CallByName puisqu'on ne peut pas écrire Data.vent_moyen.10m
ni tout mot clé réservé du Vba (d'où tes majuscules dans ton code)
Pierre
Bonjour Pierre,
MAIS ça n'exclut pas le recours obligatoire à VBA.CallByName puisqu'on ne peut pas écrire
Data.vent_moyen.10mni tout mot clé réservé du Vba (d'où tes majuscules dans ton code)
Je viens de me rendre compte qu'en ajoutant
.AddCode "Object.prototype.element=function( i ) { return this[i] } ; "on peut alors écrire ...
On Error Resume Next ' absence d'un élément
For i = 0 To ScriptEngine.Run("getProperty", data.records, "length") - 1
With data.records.element(i).element("fields")
Range("B1").Offset(0, i) = .city
Range("B2").Offset(0, i) = .element("name")
Range("B3").Offset(0, i) = .element("address")
Range("B4").Offset(0, i) = .price_gazole
Range("B5").Offset(0, i) = .price_sp95
Range("B6").Offset(0, i) = .price_sp98
Range("B7").Offset(0, i) = .price_e10
With ScriptEngine.Eval("(" + CStr(.timetable) + ")")
Range("B8").Offset(0, i) = .Lundi.ouverture & " - " & .Lundi.fermeture
Range("B9").Offset(0, i) = .Mardi.ouverture & " - " & .Mardi.fermeture
Range("B10").Offset(0, i) = .Mercredi.ouverture & " - " & .Mercredi.fermeture
Range("B11").Offset(0, i) = .Jeudi.ouverture & " - " & .Jeudi.fermeture
Range("B12").Offset(0, i) = .Vendredi.ouverture & " - " & .Vendredi.fermeture
Range("B13").Offset(0, i) = .Samedi.ouverture & " - " & .Samedi.fermeture
Range("B14").Offset(0, i) = .Dimanche.ouverture & " - " & .Dimanche.fermeture
End With
End With
Nextce qui semble résoudre ce problème pour les mots réservés !
et du coup mettre aussi en variable .element(_____ma_variable____)
Michel
Pierre,
je me suis fait plaisir avec ton excellente application -que j'utilise tous les jours- en appliquant le prototypage (réminiscence des mes années javascript)
Sub prev_meteo()
Dim ScriptEngine As Object
Set ScriptEngine = CreateObject("ScriptControl")
ScriptEngine.Language = "JScript"
ScriptEngine.AddCode "Object.prototype.element=function(i){return this[i]};"
Dim data As Object, jour As Object, j%, h%, i%, t(1 To 30, 1 To 9) As Variant
Sheets("prev").Select
Range("A1").CurrentRegion.Offset(1, 0).ClearContents
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", [www], False
.send
Set data = ScriptEngine.Eval("(" + CStr(.responsetext) + ")")
End With
For j = 0 To 4
Set jour = data.element("fcst_day_" & j) ' paramètre variable
For h = 0 To 20 Step 4
i = j * 6 + h / 4 + 1
t(i, 1) = i
t(i, 2) = horodatage(jour.element("date"), h) ' date = mot réservé
With VBA.CallByName(jour.hourly_data, h & "H00", VbGet)
t(i, 3) = .TMP2m
t(i, 4) = Int(.WNDSPD10m)
t(i, 5) = Int(.WNDGUST10m)
t(i, 6) = .WNDDIRCARD10
t(i, 7) = .element("CONDITION") ' Condition = mot réservé
t(i, 8) = .PRMSL
t(i, 9) = .APCPsfc
End With
Next
Next
ActiveSheet.Range("A2").Resize(UBound(t, 1), UBound(t, 2)) = t
Set jour = Nothing
Set data = Nothing
End Sub
Function horodatage(Dt As String, heure As Integer) As String
horodatage = Mid(Dt, 4, 2) & "/" & Mid(Dt, 1, 2) & "/" & Mid(Dt, 7, 4) & " " & heure & ":00"
End FunctionJ'avais oublié celui-ci
With jour.hourly_data.element(h & "H00") ' paramètre variablebon, je passe à autre chose maintenant !
En fait, ce topic est additif ! je n'ai pas réussi à m'en dégager ... je me suis replongé dans le javascript ...
Alors dans le genre, je peux proposer ceci :
.Language = "JScript" .AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } " .AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
Je pense que l'on peut proposer aussi plus simple pour le nombre d'occurrences et la liste des clés d'un objet (il faudrait que je supprime encore le dernier élément vide).
.AddCode "function N(jsonObj){return jsonObj.length;} "
.AddCode "function cles(jsonObj){var output = ''; for (var property in jsonObj) {output += property + '||';};return output.substr(0,output.length-2);} "Ensuite un simple split pour avoir les clés en tableau dans excel ... exemple
TxtCles = ScriptEngine.Run("cles", data.records.element(0).element("fields"))
TabCles = Split(TxtCles, "||")Bon, je me suis fait d'autres fonctions, notamment les objets de l'objet, et les attributs (couple clé/valeur) d'un objet.
Sub test()
Dim ScriptEngine As Object
Set ScriptEngine = CreateObject("ScriptControl")
With ScriptEngine
.Language = "JScript"
.AddCode "Object.prototype.element=function( i ) { return this[i] } ; "
.AddCode "function N(jsonObj){return jsonObj.length;} "
.AddCode "function attributs(jsonObj){var output = ''; for (var property in jsonObj) {if ((typeof jsonObj[property] !== 'object') && (typeof jsonObj[property] !== 'function')) {output += property + '::' + jsonObj[property] + '||';};};return output.substr(0,output.length-2);} "
.AddCode "function objets(jsonObj){var output = ''; for (var property in jsonObj) {if (typeof jsonObj[property] === 'object') {output += property + '||';};};return output.substr(0,output.length-2);} "
.AddCode "function cles(jsonObj){var output = ''; for (var property in jsonObj) {output += property + '::' + typeof jsonObj[property] + '||';};return output.substr(0,output.length-2);} "
End With
Dim data As Object
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", [www], False
.send
Set data = ScriptEngine.Eval("(" + CStr(.responsetext) + ")")
End With
TxtCles = ScriptEngine.Run("cles", data.records.element(0).element("fields"))
TabCles = Split(TxtCles, "||")
Sheets("keys").Select
Cells.ClearContents
For i = 0 To UBound(TabCles)
Cells(i + 1, 1) = Split(TabCles(i), "::")(0)
Cells(i + 1, 2) = Split(TabCles(i), "::")(1)
Next
Dim obj As Object
Set obj = data.records.element(0).element("fields")
Debug.Print "nb d'occurrences : "
Debug.Print "-------------------"
Debug.Print ScriptEngine.Run("N", data.records)
Debug.Print
Debug.Print "cité : "
Debug.Print "-------"
Debug.Print obj.city
Debug.Print
Debug.Print "clés de l'objet : "
Debug.Print "------------------"
Debug.Print ScriptEngine.Run("cles", obj) ' fields étnt un nom résrvé
Debug.Print
Debug.Print "attributs de l'objet : "
Debug.Print "-----------------------"
Debug.Print ScriptEngine.Run("attributs", obj)
Debug.Print
Debug.Print "objets de l'objet : "
Debug.Print "--------------------"
Debug.Print ScriptEngine.Run("objets", obj)
Debug.Print
End Sub