1 (изменено: omegastripes, 2016-03-11 00:41:45)

Тема: VBA: Парсинг JSON c помощью RegEx в Excel

Всем доброго времени суток. Хочу предложить метод парсинга JSON-строки c помощью RegEx для Excel VBA. В отличие от достаточно известного способа преобразования JSON-строки в объект с помощью ScriptControl:

Sub Vulnerability()
    ' вредоносная JSON-строка, полученная в ответе web-сервера, имеет доступ к файловой системе и многому другому
    jsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}"
    ' в данном случае создается файл на диске C:\
    Set jsonObj = jsonDecode(jsonString)
End Sub

Function jsonDecode(jsonString As Variant)
    Set sc = CreateObject("ScriptControl"): sc.Language = "JScript"
    Set jsonDecode = sc.Eval("(" + jsonString + ")")
End Function

данный метод не создает уязвимостей системы. Объекты {} представлены Scripting.Dictionary, что позволяет обращаться к их свойствам и методам: .Count, .Items, .Keys, .Exists(), .Item(). Массивы [] являются обычными VB-массивами с индексацией с нуля, поэтому количество элементов можно определить с помощью UBound(). Ниже привожу код с некоторыми примерами использования:

Option Explicit

Sub JsonTest()
    Dim strJsonString As String
    Dim varJson As Variant
    Dim strState As String
    Dim varItem As Variant
    
    ' преобразование JSON-строки в объект
    ' корневой элемент может быть объектом {} или массивом []
    strJsonString = "{""a"":[{}, 0, ""value"", [{""stuff"":""content""}]], b:null}"
    ParseJson strJsonString, varJson, strState
    
    ' проверка структуры шаг за шагом
    Select Case False ' если хоть одна из проверок неудачна, цепочка прервется
        Case IsObject(varJson) ' если корневой JSON-элемент является объектом,
        Case varJson.Exists("a") ' имеющим свойство a,
        Case IsArray(varJson("a")) ' являющимся массивом
        Case UBound(varJson("a")) >= 3 ' не менее чем с 4 элементами,
        Case IsArray(varJson("a")(3)) ' и 4-ый элемент - это массив,
        Case UBound(varJson("a")(3)) = 0 ' в котором единственный элемент
        Case IsObject(varJson("a")(3)(0)) ' является объектом,
        Case varJson("a")(3)(0).Exists("stuff") ' имеющим свойство stuff,
        Case Else
            ' тогда вывести значение этого свойства.
            MsgBox "Проверка структуры шаг за шагом" & vbCrLf & varJson("a")(3)(0)("stuff")
    End Select
    
    ' прямой доступ к свойству при известной структуре
    MsgBox "Прямой доступ к свойству" & vbCrLf & varJson.Item("a")(3)(0).Item("stuff") ' content
    
    ' Обход каждого элемента массива
    For Each varItem In varJson("a")
        ' показать структуру элемента
        MsgBox "Структура элемента:" & vbCrLf & BeautifyJson(varItem)
    Next
    
    ' показать структуру целиком, начиная с корневого элемента
    MsgBox "Структура целиком, начиная с корневого элемента:" & vbCrLf & BeautifyJson(varJson)
    
End Sub

Sub BeautifyTest()
    ' поместите JSON-строку в файл "desktop\source.json"
    ' переработанная JSON-строка будет сохранена в файл "desktop\result.json"
    Dim strDesktop As String
    Dim strJsonString As String
    Dim varJson As Variant
    Dim strState As String
    Dim strResult As String
    Dim lngIndent As Long
    
    strDesktop = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
    strJsonString = ReadTextFile(strDesktop & "\source.json", -2)
    ParseJson strJsonString, varJson, strState
    If strState <> "Error" Then
        strResult = BeautifyJson(varJson)
        WriteTextFile strResult, strDesktop & "\result.json", -1
    End If
    CreateObject("WScript.Shell").PopUp strState, 1, , 64
End Sub

Sub ParseJson(ByVal strContent As String, varJson As Variant, strState As String)
    ' strContent - исходная JSON-строка
    ' varJson - созданный объект или массив, возвращаемый в качестве результата
    ' strState - строка Object|Array|Error, в зависимости от результата преобразования
    Dim objTokens As Object
    Dim objRegEx As Object
    Dim bMatched As Boolean
    
    Set objTokens = CreateObject("Scripting.Dictionary")
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        ' спецификация http://www.json.org/
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = """(?:\\""|[^""])*""(?=\s*(?:,|\:|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "str"
        .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)e(?:[+-])?\d+(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "num"
        .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "num"
        .Pattern = "\b(?:true|false|null)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "cst"
        .Pattern = "\b[A-Za-z_]\w*(?=\s*\:)" ' неспецифицированные имена свойств без кавычек
        Tokenize objTokens, objRegEx, strContent, bMatched, "nam"
        .Pattern = "\s"
        strContent = .Replace(strContent, "")
        .MultiLine = False
        Do
            bMatched = False
            .Pattern = "<\d+(?:str|nam)>\:<\d+(?:str|num|obj|arr|cst)>"
            Tokenize objTokens, objRegEx, strContent, bMatched, "prp"
            .Pattern = "\{(?:<\d+prp>(?:,<\d+prp>)*)?\}"
            Tokenize objTokens, objRegEx, strContent, bMatched, "obj"
            .Pattern = "\[(?:<\d+(?:str|num|obj|arr|cst)>(?:,<\d+(?:str|num|obj|arr|cst)>)*)?\]"
            Tokenize objTokens, objRegEx, strContent, bMatched, "arr"
        Loop While bMatched
        .Pattern = "^<\d+(?:obj|arr)>$" ' неспецифицированный массив в качестве корневого элемента
        If Not (.Test(strContent) And objTokens.Exists(strContent)) Then
            varJson = Null
            strState = "Error"
        Else
            Retrieve objTokens, objRegEx, strContent, varJson
            strState = IIf(IsObject(varJson), "Object", "Array")
        End If
    End With
End Sub

Sub Tokenize(objTokens, objRegEx, strContent, bMatched, strType)
    Dim strKey As String
    Dim strRes As String
    Dim lngCopyIndex As Long
    Dim objMatch As Object
    
    strRes = ""
    lngCopyIndex = 1
    With objRegEx
        For Each objMatch In .Execute(strContent)
            strKey = "<" & objTokens.Count & strType & ">"
            bMatched = True
            With objMatch
                objTokens(strKey) = .Value
                strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey
                lngCopyIndex = .FirstIndex + .Length + 1
            End With
        Next
        strContent = strRes & Mid(strContent, lngCopyIndex, Len(strContent) - lngCopyIndex + 1)
    End With
End Sub

Sub Retrieve(objTokens, objRegEx, strTokenKey, varTransfer)
    Dim strContent As String
    Dim strType As String
    Dim objMatches As Object
    Dim objMatch As Object
    Dim strName As String
    Dim varValue As Variant
    Dim objArrayElts As Object
    
    strType = Left(Right(strTokenKey, 4), 3)
    strContent = objTokens(strTokenKey)
    With objRegEx
        .Global = True
        Select Case strType
            Case "obj"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set varTransfer = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varTransfer
                Next
            Case "prp"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                
                Retrieve objTokens, objRegEx, objMatches(0).Value, strName
                Retrieve objTokens, objRegEx, objMatches(1).Value, varValue
                If IsObject(varValue) Then
                    Set varTransfer(strName) = varValue
                Else
                    varTransfer(strName) = varValue
                End If
            Case "arr"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set objArrayElts = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varValue
                    If IsObject(varValue) Then
                        Set objArrayElts(objArrayElts.Count) = varValue
                    Else
                        objArrayElts(objArrayElts.Count) = varValue
                    End If
                    varTransfer = objArrayElts.Items
                Next
            Case "nam"
                varTransfer = strContent
            Case "str"
                varTransfer = Mid(strContent, 2, Len(strContent) - 2)
                varTransfer = Replace(varTransfer, "\""", """")
                varTransfer = Replace(varTransfer, "\\", "\")
                varTransfer = Replace(varTransfer, "\/", "/")
                varTransfer = Replace(varTransfer, "\b", Chr(8))
                varTransfer = Replace(varTransfer, "\f", Chr(12))
                varTransfer = Replace(varTransfer, "\n", vbLf)
                varTransfer = Replace(varTransfer, "\r", vbCr)
                varTransfer = Replace(varTransfer, "\t", vbTab)
                .Global = False
                .Pattern = "\\u[0-9a-fA-F]{4}"
                Do While .Test(varTransfer)
                    varTransfer = .Replace(varTransfer, ChrW(("&H" & Right(.Execute(varTransfer)(0).Value, 4)) * 1))
                Loop
            Case "num"
                varTransfer = Evaluate(strContent)
            Case "cst"
                Select Case LCase(strContent)
                    Case "true"
                        varTransfer = True
                    Case "false"
                        varTransfer = False
                    Case "null"
                        varTransfer = Null
                End Select
        End Select
    End With
End Sub

Function BeautifyJson(varJson As Variant) As String
    Dim strResult As String
    Dim lngIndent As Long
    BeautifyJson = ""
    lngIndent = 0
    BeautyTraverse BeautifyJson, lngIndent, varJson, vbTab, 1
End Function

Sub BeautyTraverse(strResult As String, lngIndent As Long, varElement As Variant, strIndent As String, lngStep As Long)
    Dim arrKeys() As Variant
    Dim lngIndex As Long
    Dim strTemp As String

    Select Case VarType(varElement)
        Case vbObject
            If varElement.Count = 0 Then
                strResult = strResult & "{}"
            Else
                strResult = strResult & "{" & vbCrLf
                lngIndent = lngIndent + lngStep
                arrKeys = varElement.Keys
                For lngIndex = 0 To UBound(arrKeys)
                    strResult = strResult & String(lngIndent, strIndent) & """" & arrKeys(lngIndex) & """" & ": "
                    BeautyTraverse strResult, lngIndent, varElement(arrKeys(lngIndex)), strIndent, lngStep
                    If Not (lngIndex = UBound(arrKeys)) Then strResult = strResult & ","
                    strResult = strResult & vbCrLf
                Next
                lngIndent = lngIndent - lngStep
                strResult = strResult & String(lngIndent, strIndent) & "}"
            End If
        Case Is >= vbArray
            If UBound(varElement) = -1 Then
                strResult = strResult & "[]"
            Else
                strResult = strResult & "[" & vbCrLf
                lngIndent = lngIndent + lngStep
                For lngIndex = 0 To UBound(varElement)
                    strResult = strResult & String(lngIndent, strIndent)
                    BeautyTraverse strResult, lngIndent, varElement(lngIndex), strIndent, lngStep
                    If Not (lngIndex = UBound(varElement)) Then strResult = strResult & ","
                    strResult = strResult & vbCrLf
                Next
                lngIndent = lngIndent - lngStep
                strResult = strResult & String(lngIndent, strIndent) & "]"
            End If
        Case vbInteger, vbLong, vbSingle, vbDouble
            strResult = strResult & varElement
        Case vbNull
            strResult = strResult & "Null"
        Case vbBoolean
            strResult = strResult & IIf(varElement, "True", "False")
        Case Else
            strTemp = Replace(varElement, "\""", """")
            strTemp = Replace(strTemp, "\", "\\")
            strTemp = Replace(strTemp, "/", "\/")
            strTemp = Replace(strTemp, Chr(8), "\b")
            strTemp = Replace(strTemp, Chr(12), "\f")
            strTemp = Replace(strTemp, vbLf, "\n")
            strTemp = Replace(strTemp, vbCr, "\r")
            strTemp = Replace(strTemp, vbTab, "\t")
            strResult = strResult & """" & strTemp & """"
    End Select
    
End Sub

Function ReadTextFile(strPath As String, lngFormat As Long) As String
    ' lngFormat -2 - System default, -1 - Unicode, 0 - ASCII
    With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 1, False, lngFormat)
        ReadTextFile = ""
        If Not .AtEndOfStream Then ReadTextFile = .ReadAll
        .Close
    End With
End Function

Sub WriteTextFile(strContent As String, strPath As String, lngFormat As Long)
    With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 2, True, lngFormat)
        .Write (strContent)
        .Close
    End With
End Sub
Щт Уккщк Куыгьу Туче

2

Re: VBA: Парсинг JSON c помощью RegEx в Excel

Последнюю версию можно найти по ссылке https://github.com/omegastripes/VBA-JSON-parser

Щт Уккщк Куыгьу Туче

3

Re: VBA: Парсинг JSON c помощью RegEx в Excel

omegastripes, приетствую. А такой вариант Вам не подошёл ?

Option Explicit
Dim Script As New ScriptControl, _
    xhr As New MSXML2.XMLHTTP60, _
    JSON As Object, _
    obj As Object
    
Sub Test()
    'Подгрузка библиотеки JSON
    xhr.Open "GET", "https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js", False
    xhr.send
    Script.Language = "JavaScript"
    Script.AddCode xhr.responseText
    'Получение объекта JSON парсера для безопасной работы с JSON данными
    Set JSON = Script.CodeObject.JSON
    Set obj = JSON.parse("{""a"":1,""b"":2}")
    obj.a = "test"
    obj.b = "test2"
    MsgBox JSON.stringify(obj)
End Sub
Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

4

Re: VBA: Парсинг JSON c помощью RegEx в Excel

Xameleon, из очевидных недостатков - ScriptControl не доступен в 64-битных версиях офиса, только через костыль с созданием ScriptControl в 32-битном процессе и передачей в VBA. По быстродействию и удобству использования элементов объекта в циклах - не готов сказать, нужно тестировать.

Щт Уккщк Куыгьу Туче

5

Re: VBA: Парсинг JSON c помощью RegEx в Excel

omegastripes, понял. Тогда альтернатива:


Option Explicit
Sub Test()
    Dim xhr, document, window, JSON, obj
    'Подгрузка библиотеки JSON
    Set xhr = CreateObject("Microsoft.XMLHTTP")
    xhr.Open "GET", "https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js", False
    xhr.send
    Set document = CreateObject("htmlfile")
    Set window = document.parentWindow
    window.execScript xhr.responseText
    Set JSON = window.JSON
    Set obj = JSON.parse("{""a"":1,""b"":2}")
    obj.a = "test"
    obj.b = "test2"
    MsgBox JSON.stringify(obj)
End Sub
Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

6

Re: VBA: Парсинг JSON c помощью RegEx в Excel

Для оценки скорости работы можно потестить на таком варианте - загрузка 10 000 записей и их парсинг.
В код пришлось добавить метод в прототип объектов для чтения атрибутов объекта, так как злостный Word исправлял имена свойств, меняя первую букву на заглавную.


Option Explicit
Sub Test()
    Dim xhr, document, window, JSON, obj
    'Подгрузка библиотеки JSON
    Set xhr = CreateObject("Microsoft.XMLHTTP")
    xhr.Open "GET", "https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js", False
    xhr.send
    Set document = CreateObject("htmlfile")
    Set window = document.parentWindow
    window.execScript xhr.responseText
    window.execScript "Object.prototype.attr = function(name){return this[name]}"
    Set JSON = window.JSON
    
    MsgBox "Загрузка 10 000 записей"
    xhr.Open "GET", "http://trirand.com/blog/phpjqgrid/examples/jsonp/getjsonp.php?qwery=longorders&rows=10000", True
    xhr.send
    While xhr.readyState <> 4
        DoEvents
    Wend
    On Error Resume Next
    Set obj = JSON.parse(xhr.responseText)
    If Err.Number <> 0 Then
        MsgBox "Ошибка разбора JSON данных.", vbCritical
        Exit Sub
    End If
    On Error GoTo 0
    
    MsgBox "Загружено записей: " & obj.attr("rows").attr("length")
    Debug.Print JSON.stringify(obj, "", vbTab)
End Sub
Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

7

Re: VBA: Парсинг JSON c помощью RegEx в Excel

Сравнил быстродействие парсинга и сериализации с помощью кода из второго и шестого постов, по среднему за 5 прогонов, в качестве сэмпла взял предложенные 10000 записей. В первом случае потребовалось 23,3 с на парсинг и 8,01 с на сериализацию, соответственно. Во втором случае - 0,468 с и 0,485 с, что в общем-то свойственно нативному eval(). В принципе, на этих результатах уже можно и заканчивать сравнение. Добавлю лишь немного.

Проверил скорость доступа к элементам в цикле.
Для второго поста For Each длится 0,0195 с, For Next - 0,0234 с:

arrRows = vJSON("rows")
For Each objRow In arrRows
    s = objRow("CustomerID")
Next
For i = 0 To UBound(arrRows)
    s = arrRows(i)("CustomerID")
Next

Для шестого поста For Each выдает ошибку, For Next - 0,227 с:

Set colRows = obj.attr("rows")
'For Each objRow In colRows
'    Debug.Print objRow.attr("CustomerID")
'Next
For i = 0 To colRows.attr("length") - 1
    s = colRows.attr(i).attr("CustomerID")
Next

Как реализовать доступ к элементам в цикле For Each?

Ну и для доведения кода из 6 поста до завершенного вида, на мой взгляд, все-таки нужно отвязать его от внешего источника, "инкапсулировав" JS код внутрь VBA (в свое время делал подобное, сохраняя JS код в виде base64-кодированных строк в VBA функции).

Щт Уккщк Куыгьу Туче

8

Re: VBA: Парсинг JSON c помощью RegEx в Excel

omegastripes, обычный For Each не получится, так как для этого объект должен поддерживать интерфейс IUnknown, а модель JavaScript массивов иначе устроена. Там возврат подразумевается через new Enumerator по виду близкому к Recordset. Подробнее вот тут: тут.

Так что либо делать "костыли", либо использовать счетчик. ) Но конечно остаётся ещё вариант с for i in array, но он тоже не очень красив.

Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !