読者です 読者をやめる 読者になる 読者になる

【VBA】VBAでjsonのパーサを作ってみよう

JsonObjectの方でItemプロパティを使うようにしました。

前書き

なんとかVBAでjsonをパースすることが出来るようになったのはいいけれど、なんでjsonごときにここまで苦戦せにゃならんのだと思うのは正しいし、汎用的なパーサを作ってしまうのがいいのでは?と思うのも当然と言えば当然の流れ。

で、作りました。読むだけで出力は出来ません。てか、それならもうJavascriptで全部書けって話ですよ。

とりあえずもう暫くVBAは書きたくないです。

1.今回使うjson

コードを紹介する前に、今回テストしてみたハチャメチャなjsonを紹介し、これをどう言うオブジェクトに変換したらいいのかを考えて見ます。

今回テストしてみたjsonはこれです。

[{"hoge":{ "piyo":{"fugapiyo":[{"foo":1},{"bar":2}]}, "fuga":[3,4], "hogepiyo":[5,6], "hogefuga":7 }}]

整形するとこんな感じ。

[
    {
        "hoge": {
            "piyo": {
                "fugapiyo": [
                    {
                        "foo": 1
                    }, 
                    {
                        "bar": 2
                    }
                ]
            }
            "fuga": [
                3, 
                4
            ], 
            "hogefuga": 7, 
            "hogepiyo": [
                5, 
                6
            ], 
        }
    }
]

整形するとキー以外は思ったよりハチャメチャじゃないですね。

2.作ってみたコード

とりあえず、パースするためのクラスと、パースした結果をラップするためのクラスを作ってみました。

JsonParser

Option Explicit
'********************
'JsonParser
'
'Jsonパース処理
'パースした結果はJsonObjectでラップされる
'
'注意:JsonObject→自作したJsonObjectと言うDictionaryのラッパークラス
'   Json(JScriptTypeInfo)→Javascriptでevalした結果のObject
'********************


Private m_js As Object  'javascript実行用オブジェクト

'********************
'コンストラクタ
'処理中で使用するJavascriptの定義を行う
'********************
Public Sub Class_Initialize()
    Set m_js = CreateObject("ScriptControl")
    m_js.Language = "JScript"
    
    'JsonをevalするJavactipt
    m_js.AddCode "function jsonParse(str) { return eval('(' + str + ')'); };"
    
    'Jsonからキーの配列を取得するJavascript
    m_js.AddCode "function getKeys(h) { var keys=[]; for(var k in h){keys.push(k);} return keys; };"
    
    'Jsonが配列かどうかを確認するJavascript
    m_js.AddCode "function isArray(o) { return o instanceof Array; };"
End Sub

'********************
'デストラクタ
'********************
Private Sub Class_Terminate()
    Set m_js = Nothing
End Sub

'********************
'パース処理呼び出し
'
'Argument:Jsonの形式になっている文字列(String)
'Return :Collection(JsonObject)もしくはJsonObject
'     引数がJson形式でなかった場合はNothing
'********************
Public Function Parse(ByVal strJson As String) As Object
    
    Dim json As Object
    
    On Error GoTo ParseError
    Set json = m_js.codeobject.jsonParse(strJson)
    On Error GoTo 0
    
    'valueを解析した結果がJScriptTypeInfoかどうかを判定する
    'JScriptTypeInfo以外の場合はNothingを返す
    If IsJson(json) Then
        If IsJsonArray(json) Then
            Set Parse = JsonArrayToCollection(json)
        Else
            Set Parse = JsonToDictionary(json)
        End If
    Else
        Set Parse = Nothing
    End If

    Exit Function
    
ParseError:
    
    Debug.Print Err.Description
    Set Parse = Nothing
    
End Function

'********************
'Jsonの配列をCollectionに変換する
'
'Argument:Jsonの配列(JScriptTypeInfo)
'Return :Key:Jsonで使用されているキー Value:JsonObjectのCollection
'********************
Private Function JsonArrayToCollection(ByVal json As Object) As Collection

    Dim col As New Collection
    Dim key As Variant
    Dim objJson As Object
    Dim varJson As Variant
    Dim jsonObj As JsonObject
    Dim jsonData As Dictionary
    
    For Each key In GetKeys(json)
        
        On Error GoTo VariantPattern
        Set objJson = GetObject(json, key)
        
        
        If IsJsonArray(objJson) Then
            '配列だった場合は再帰させる
            Call col.Add(JsonArrayToCollection(objJson), key)
        Else
            '一要素だった場合はJsonObjectをCollectionに追加する
            Call col.Add(JsonToDictionary(objJson), key)
        End If
        
        GoTo Continue
            
VariantPattern:
        On Error GoTo 0
        varJson = GetValue(json, key)
        Set jsonObj = New JsonObject
        Set jsonData = New Dictionary
        
        Call jsonData.Add(key, varJson)
        Call jsonObj.Init(jsonData)
        Call col.Add(jsonObj, key)
        
        Resume Continue

Continue:
    Next
    
    On Error GoTo 0
    
    Set JsonArrayToCollection = col

End Function

'********************
'Jsonの配列をDictionaryに変換する
'
'Argument:Json(JScriptTypeInfo)
'Return :Key:Jsonで使用されているキー Value:Json.keyのJsonObject
'********************
Private Function JsonToDictionary(ByVal json As Object) As JsonObject
    
    Dim jsonDictionary As New Dictionary
    Dim col As New Collection
    Dim collectionValue As Variant
    Dim jsonObj As New JsonObject
    Dim key As Variant
    Dim objJson As Object
    Dim varJson As Variant
    Dim obj As Object
    Dim var As Variant
    
    For Each key In GetKeys(json)
        
        On Error GoTo VariantPattern
        Set objJson = GetObject(json, key)
        On Error GoTo 0
        
        If IsJsonArray(objJson) Then
            '配列だった場合はKey:Jsonのキー Value:Collection(JsonObject)となるDictionaryを作成
            'Collection(JsonObject)の作成
            
            For Each collectionValue In objJson
                'Collection作成中にJsonの配列が現れた場合は再帰させる
                If IsJson(collectionValue) Then
                    Call col.Add(JsonToDictionary(collectionValue))
                Else
                    Call col.Add(collectionValue)
                End If
            Next
            
            Call jsonDictionary.Add(key, col)
        Else
            On Error GoTo ObjectPattern
            var = GetValue(objJson, key)
            On Error GoTo 0
            Call jsonDictionary.Add(key, var)
            GoTo Continue
        End If
        
        GoTo Continue

ObjectPattern:
        Call jsonDictionary.Add(key, JsonToDictionary(objJson))
        Resume Continue

VariantPattern:
        On Error GoTo 0
        Call jsonDictionary.Add(key, GetValue(json, key))
        Resume Continue
Continue:
    Next
    
    '作成し終わったDictionaryでJsonObjectを作る
    Call jsonObj.Init(jsonDictionary)
    
    Set JsonToDictionary = jsonObj
    
End Function

'********************
'配列チェック
'
'Argument:Json(JScriptTypeInfo)
'Return :引数が配列ならばTrue、配列でなければFalse
'********************
Private Function IsJsonArray(ByVal json As Object) As Boolean
    IsJsonArray = CallByName(m_js.codeobject, "isArray", VbMethod, json)
End Function

'********************
'キー取得
'
'Argument:Json(JScriptTypeInfo)
'Return :引数のキーの配列
'********************
Private Function GetKeys(ByVal json As Object) As Object
    Set GetKeys = CallByName(m_js.codeobject, "getKeys", VbMethod, json)
End Function

Private Function IsJson(ByVal obj) As Boolean
    IsJson = TypeName(obj) = "JScriptTypeInfo"
End Function

Private Function GetObject(ByVal json As Object, ByVal key As Variant) As Object
    Set GetObject = CallByName(json, key, VbGet)
End Function

Private Function GetValue(ByVal json As Object, ByVal key As Variant) As Variant
    GetValue = CallByName(json, key, VbGet)
End Function

JsonObject

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "JsonObject"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'********************
'JsonObject
'
'JsonParserによって作成されたDictionaryを使いやすくしたラッパ
'********************
 
Private m_keys As New Collection    '所有しているキー
Private m_data As Dictionary        'ラップしているデータ
Private m_inited As Boolean         '初期化済み判定

Public Property Get JsonKeys() As Collection
    Set JsonKeys = m_keys
End Property

Public Property Get Item(ByVal key As String)
Attribute Item.VB_UserMemId = 0

    ' "."が含まれているかどうかを調べる
    If InStr(key, ".") = 0 Then
        ' "."が含まれていない場合はそのままキーとして使用し、データを返す
        If IsObject(m_data(key)) Then
            Set Item = m_data(key)
        Else
            Item = m_data(key)
        End If
    Else
        Dim keys() As String
        Dim i As Long
        Dim tmp
        
        ' キーを分解する
        keys = Split(key, ".")
        
        Set tmp = m_data(keys(0))
        
        ' キーを一つ一つ調査していき、最後に取得した何かしらを返す
        For i = 1 To UBound(keys)
            If i = UBound(keys) Then
                If IsObject(tmp(keys(i))) Then
                    Set Item = tmp(keys(i))
                Else
                    Item = tmp(keys(i))
                End If
            Else
                Set tmp = tmp(keys(i))
            End If
        Next
    End If
End Property

'********************
'デストラクタ
'********************
Private Sub Class_Terminate()
  Set m_keys = Nothing
  Set m_data = Nothing
End Sub
 
'********************
'初期化
'Argument:JsonParserでパースし終わったDictionary
'********************
Public Sub Init(ByVal jsonData As Dictionary)
    Dim key As Variant
     
    '一度でもInitが呼ばれていたら何もしない
    If m_inited Then Exit Sub
     
    For Each key In jsonData.keys
        m_keys.Add (key)
    Next
    
    Set m_data = jsonData
    m_inited = True
     
End Sub
 
'********************
'キー存在チェック
'Argument:チェックしたいキー
'Return :引数のキーが存在したらTrue、しなければFalse
'********************
Public Function HasKey(ByVal key As String) As Boolean
 
    Dim keyCache As Variant
     
    For Each keyCache In m_keys
        If key = keyCache Then
            HasKey = True
            Exit Function
        End If
    Next
     
    HasKey = False
End Function
 
'********************
'配列チェック
'Argument:チェックしたいキー
'Return :引数のキーから取得できるItemがCollectionならTrue、それ以外ならFalse
'     また、キーそのものがない場合もFalseを返す
'********************
Public Function IsArray(ByVal key As String) As Boolean
    Dim obj As Object
     
    IsArray = False
     
    If Not HasKey(key) Then Exit Function
     
    If TypeName(m_data.Item(key)) = "Collection" Then
        IsArray = True
    End If
     
End Function

えー、コメントと変数名に関しては力尽きました。

JsonParserの方はそのままコピペで大丈夫ですが、JsonObjectの方はAttributeを設定しているので一旦ファイルに保存してインポートしてください。お手数おかけします。

3.使い方

もう一度今回使うjsonを紹介しておきましょう。

[
    {
        "hoge": {
            "piyo": {
                "fugapiyo": [
                    {
                        "foo": 1
                    }, 
                    {
                        "bar": 2
                    }
                ]
            }
            "fuga": [
                3, 
                4
            ], 
            "hogefuga": 7, 
            "hogepiyo": [
                5, 
                6
            ], 
        }
    }
]

JsonParserを呼び出します。

Dim parser As New JsonParser
Dim objJson As Object

Set objJson = parser.Parse("[{""hoge"":{ ""piyo"":{""fugapiyo"":[{""foo"":1},{""bar"":2}]}, ""fuga"":[3,4], ""hogepiyo"":[5,6], ""hogefuga"":7 }}]")

今回はrootが配列のjsonを渡しているので、objJsonにCollectionが返ってきます。配列でない場合は直接JsonObjectが返ってきます。

とりあえず、hogeを取ってみましょう。

配列部分はCollectionになっているので普通に添字です。

JsonObjectはItemプロパティを設定しているので、普通にDictionaryから取得するような感じでいけます。

Dim hoge As JsonObject: Set hoge = objJson(1)("hoge")

チェーンメソッドメソッドじゃないけど)も出来ます。

'7がイミディエイトウィンドウに出力される
Debug.Print objJson(1)("hoge")("hogefuga")

これだと流石にキモいので、最初からJsonライクなキーを渡してもOKです。

'7がイミディエイトウィンドウに出力される
Debug.Print objJson(1)("hoge.hogefuga")

fooの値をワンライナーで取ろうとすると途中でコレクションが挟まってしまうので中々キモいです。

'1がイミディエイトウィンドウに出力される
Debug.Print objJson(1)("hoge.piyo.fugapiyo")(1)("foo")

Collectionなので当然For Eachも出来ます。中身がJsonObjectだとわかっているならそれで受けた方が楽です。

Dim jsObj As JsonObject

For Each jsObj In objJson(1)("hoge.piyo.fugapiyo")
    If jsObj.HasKey("foo") Then
        '1がイミディエイトウィンドウに出力される
        Debug.Print jsObj("foo")
    ElseIf jsObj.HasKey("bar") Then
        '2がイミディエイトウィンドウに出力される
        Debug.Print jsObj("bar")
    End If
Next
Dim jsObj As JsonObject
Dim tmpCollection As Collection
Dim key As Variant

Set tmpCollection = objJson(1)("hoge.piyo.fugapiyo")

For Each jsObj In tmpCollection
    For Each key In jsObj.JsonKeys
        '1と2がイミディエイトウィンドウに出力される
        Debug.Print jsObj(key)
    Next
Next

配列の中にキーがなく、普通に値が入っている場合はCollectionの添字で取り出します。

'3がイミディエイトウィンドウに表示される
Debug.Print objJson(1)("hoge.fuga")(1)

4.おわりに

VBAjsonはやめとけ。