VBSでJSONパーサ

なんで作ったの？

ネイティブなVBSだとJSONパーサがないので作ってみました。

仕様

JSON形式の文字列をScripting.Dictionary形式のオブジェクトに格納し、
返します。

ソース

'##############################################################################
' JSON2Dict
' JSON文字列をDictoinaryオブジェクトに変換するスクリプト
'##############################################################################

'##############################################################################
' エントリポイント
'##############################################################################
Main
MsgBox "Done!"

'##############################################################################
' メイン処理
'##############################################################################
Sub Main()
    If WScript.Arguments.Count = 0 Then
        MsgBox "JSONファイルをD&Dしてくださいな。",vbCritical,WScript.ScriptName
        WScript.Quit
    End If
    lsStr = Trim(Replace(LoadTextFile(WScript.Arguments(0)),vbCrLf,""))
    Set loDic = JSON2Dic(lsStr,1,cDicIdx,1)
    SaveTextFile Replace(WScript.Arguments(0),".json","_dic.txt"),Dic2Str(loDic,0)
End Sub

'##############################################################################
' JSON文字列をDictoinaryオブジェクトに変換
'##############################################################################
Function JSON2Dic(lsStr,ByVal llPtr,ByVal llIdx,ByRef llRet)
    Const cIdxArr = 0       ' 配列モード
    Const cIdxDic = -1      ' Dictionaryモード
    Const cIdxKey = 0       ' キー文字列モード
    Const cIdxVal = 1       ' 値文字列モード
    Dim lvVal(1)            ' キー・値格納用文字列配列
    Erase lvVal             ' 配列を初期化
    llMd = cIdxKey          ' 文字列追記モード
    lbEsc = False           ' エスケープフラグ
    lbStr = False           ' "で囲まれているかどうか
    ' ディクショナリオブジェクトを生成
    Set loDic = CreateObject("Scripting.Dictionary")
    ' 1文字単位でスキャン
    For i = llPtr To Len(lsStr)
        ' 文字列から1文字取り出す
        lsChr = Mid(lsStr,i,1)
        ' ダブルクォーテーションで囲まれた文字列の処理
        If lbStr Then
            lbAdd = False
            Select Case True
                Case lsChr = "\"            ' エスケープ文字
                    ' エスケープモードON
                    lbEsc = True
                Case lbEsc                  ' エスケープモード中
                    ' 文字追加モードON
                    lbAdd = True
                    ' エスケープモードOFF
                    lbEsc = False
                Case lsChr = """"           ' ダブルクォーテーションの場合
                    ' ダブルクォーテーション領域の終了
                    lbStr = False
                Case Else                   ' その他文字
                    ' 文字追加モードON
                    lbAdd = True
            End Select
            ' 文字追加モードがONの場合、文字を追加
            If lbAdd Then lvVal(llMd) = lvVal(llMd) & lsChr
        ' JSONキーワード処理
        Else
            ' 文字種で分岐
            Select Case lsChr
                Case "[","{"                ' ブロックの開始
                    ' かっこの種類で子ブロックの初期モードを決定する
                    If lsChr = "[" Then
                        llType = cIdxArr
                    Else
                        llType = cIdxDic
                    End If
                    If llPtr = 1 Then       ' 最初に現れたカッコはオブジェクトとして追加せずルートにする
                        Set loDic = JSON2Dic(lsStr,i + 1,llType,llRet)
                    Else                    ' 再帰で作成したディクショナリオブジェクトを追加する
                        If llIdx >= 0 Then
                            loDic.Add llIdx,JSON2Dic(lsStr,i + 1,llType,llRet)
                            llIdx = llIdx + 1
                        Else
                            loDic.Add Trim(lvVal(cIdxKey)),JSON2Dic(lsStr,i + 1,llType,llRet)
                        End If
                        Erase lvVal
                    End If
                    i = llRet               ' 再帰で処理した最終位置をフィードバック
                Case "}","]",","            ' ブロックの終了、キーと値ペアの区切り
                    llMd = cIdxKey
                    ' 要素を追加する
                    If lvVal(cIdxKey) <> "" Then
                        If llIdx >= 0 Then
                            loDic.Add llIdx,Trim(lvVal(cIdxVal))
                            llIdx = llIdx + 1
                            MsgBox lvVal(cIdxKey)
                        Else
                            loDic.Add Trim(lvVal(cIdxKey)),Trim(lvVal(cIdxVal))
                        End If
                    End If
                    Erase lvVal
                    ' カンマ以外はブロックの終了を示すのでForから抜ける
                    If lsChr <> "," Then Exit For
                Case ":"                    ' キーと値の区切り文字
                    llMd = cIdxVal
                Case """"                   ' ダブルクォーテーション
                    lbStr = True
                Case Else                   ' その他の文字
                    lvVal(llMd) = lvVal(llMd) & lsChr
            End Select
        End If
    Next
    llRet = i
    Set JSON2Dic = loDic
End Function

'##############################################################################
' Dictionaryオブジェクトを文字列に変換
'##############################################################################
Function Dic2Str(loDic,llDepth)
    lsStr = ""
    lvKeys = loDic.Keys
    lvVals = loDic.Items
    For i = 0 To loDic.Count - 1
        lsStr = lsStr & String(llDepth," ") & lvKeys(i) & " = "
        If IsObject(lvVals(i)) Then
            lsStr = lsStr & vbCrLf & Dic2Str(lvVals(i),llDepth + 4)
        Else
            lsStr = lsStr & lvVals(i) & vbCrLf
        End If
    Next
    Dic2Str = lsStr
End Function

'##############################################################################
' テキストファイルを読み込み文字列で返す
'##############################################################################
Function LoadTextFile(lsPath)
    LoadTextFile = ""
    Set loFs = Createobject("Scripting.FileSystemObject")
    If loFs.FileExists(lsPath) Then
        Set loTs = loFs.OpenTextFile(lsPath,1)
        LoadTextFile = loTs.ReadAll
        loTs.Close
        Set loTs = Nothing
    End If
    Set loFs = Nothing
End Function

'##############################################################################
' 文字列をテキストファイルに書き込む
'##############################################################################
Sub SaveTextFile(lsPath,lsStr)
    Set loFs = Createobject("Scripting.FileSystemObject")
    Set loTs = loFs.OpenTextFile(lsPath,2,True)
    loTs.Write lsStr
    loTs.Close
    Set loTs = Nothing
    Set loFs = Nothing
End Sub