Parse Json VBA 64 Bits

Bonjour à tous,

J'ai développé un petit fichier Excel qui me permet de récupérer des données de géocodage.

Je me suis appuyé fortement sur des échanges sur le sujet sur ce forum, notamment de l'excellent Pierrep56 sur le sujet.

Au final, le code fonctionne très bien sur Excel 32 bits, mais sur du 64 bits, le code bloque dès le départ sur le create du scriptcontrol.

J'ai fait pas mal de recherches sur le sujet d'adaptation 32/64, mais j'avoue que je suis complètement bloqué pour trouver une solution, en imaginant en plus que sans doute la suite du code pourrait être impacté sur du 64 bits également. Et je ne peux malheureusement m'en passer, l'ensemble des personnes pouvant être amené à utiliser le fichier étant soit sur du 32 soit sur 64...

Alors je fais appel à votre aide d'experts.

Voici le code ci-dessous et je vous joins également le fichier.

Merci d'avance à tous,

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 decrypterJSON()
Dim JsonString As String
Dim JsonObject As Object, http As Object

Dim shtData As Worksheet
Dim nLg, nLg2 As Long, i As Long
Dim deb, fin As Integer
Dim D_AdrRqt, A_AdrRqt, rqt, URL, result As String

Dim Keys() As String
Dim Value As Variant
Dim SousObject As Object

Dim longi, lati, nom_iris, iris, insee, adre, ville As String

Set shtData = Sheets("IRISAGE")
Application.ScreenUpdating = False
D_AdrRqt = vbNullString

    '*****************************************
    'Calcul des dernières lignes automatique
    '*****************************************
    nLg = Sheets("IRISAGE").Range("D65000").End(xlUp).Row
    nLg2 = Sheets("IRISAGE").Range("D65000").End(xlUp).Row

    deb = Sheets("IRISAGE").Range("F2").Value
    fin = Sheets("IRISAGE").Range("F3").Value
    'MsgBox (nLg)

    If nLg < 7 Then
        MsgBox "Veuillez renseigner au moins une adresse !", vbOKOnly, "Pas d'adresse"
        Exit Sub
    End If

    '*****************************************
    'Début de la boucle pour le fichier
    '*****************************************

    For i = deb To fin Step 1
        'Vérification et construction de l'adresse pour IRISAGE
        If shtData.Cells(i, 4).Value <> "" And shtData.Cells(i, 5).Value <> "" Then
            'D_AdrRqt = SansAccent(shtData.Cells(i, 1).Value) & "&postcode=" & Format(shtData.Cells(i, 2).Value, "00000")
            D_AdrRqt = SansAccent(shtData.Cells(i, 3).Value) & "%20" & Format(shtData.Cells(i, 4).Value, "00000") & "%20" & Cells(i, 5).Value
            D_AdrRqt = Replace(D_AdrRqt, " ", "%20")
            'MsgBox (D_AdrRqt)
        End If

        URL = Cells(1, 1) & D_AdrRqt & ""

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

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

        Keys = GetKeys(JsonObject)

        longi = GetProperty(JsonObject, Keys(0))
        lati = GetProperty(JsonObject, Keys(3))
        nom_iris = GetProperty(JsonObject, Keys(1))
        iris = GetProperty(JsonObject, Keys(6))
        insee = GetProperty(JsonObject, Keys(2))
        adre = GetProperty(JsonObject, Keys(5))
        ville = GetProperty(JsonObject, Keys(4))

        Cells(i, 7).Value = adre
        Cells(i, 8).Value = ville
        Cells(i, 9).Value = longi
        Cells(i, 10).Value = lati
        Cells(i, 11).Value = insee
        Cells(i, 12).Value = iris
        Cells(i, 13).Value = nom_iris

    Next i

Application.ScreenUpdating = False
End Sub

bonjour,

peut-être ceci pourra-t-il t'aider.

https://stackoverflow.com/questions/9725882/getting-scriptcontrol-to-work-with-excel-2010-x64

Bonjour,

ci-jointe version 64 bits