VBAでJSON文字列を読み込む

## 課題
VBAで顧客ごとに微妙に設定を変得なければならないケースがあり、INIファイルを使っていたがより柔軟な設定にできるようにJSONを使いたい。
※VBA-JSONがgitで公開されているが今回は自作する。

## 実装
構成ファイルをJSONにするのが目的なのでとりあえずは読み込み(Parse)のみ。目的からするとエンコード等は厳密でなくてもよいかと思ったがUnicode escapeは勉強もかねて組み込む。
ファイルから読み込んだJSON形式の文字列をParse("JSON文字列")すると、DictionaryかCollectionを返す。

### ソースコード
```vb
Option Explicit
Const BOO As String = "{"
Const EOO As String = "}"
Const BOA As String = "["
Const EOA As String = "]"
Const MS As String = ","
Const NVS As String = ":"

'unicode surrogate
Const MIN_HSG As Long = "&HD800"
Const MAX_HSG As Long = "&HDBFF"
Const MIN_LSG As Long = "&HDC00"
Const MAX_LSG As Long = "&HDFFF"

Dim gPos As Long
Dim gStr As String
Dim gObj As Object

Function Parse(strText As String) As Object

    gPos = 0
    gStr = Trim(Application.WorksheetFunction.Clean(strText))
    If Len(gStr) < 2 Then
        Set Parse = New Dictionary
        Exit Function
    End If

    Dim obj As Object
    gPos = 1
    If Left(gStr, 1) = BOO Then
        Set obj = GetObject
    ElseIf Left(gStr, 1) = BOA Then
        Set obj = GetArray
    Else
        Err.Raise 60001, "JSON.Parse", "Invalid JSON Text"
    End If
    
    Set Parse = obj
End Function

Private Function GetObject() As Dictionary
    Dim d As Dictionary
    Dim blnHasMore As Boolean
    Set d = New Dictionary
    SkipWhiteSpaces
    If Mid(gStr, gPos, 1) <> BOO Then
         Err.Raise 60001, "JSON.GetObject", "Expecting " & BOO & ", received " & Mid(gStr, gPos, 1)
    End If
    gPos = gPos + 1
    SkipWhiteSpaces
    If Mid(gStr, gPos, 1) = EOO Then 'empty object
        Set GetObject = d
        gPos = gPos + 1
        Exit Function
    End If
    
    Do
        AddMember d
    Loop While HasMore
    
    SkipWhiteSpaces
    If Mid(gStr, gPos, 1) = EOO Then
        Set GetObject = d
        gPos = gPos + 1
    Else
        Err.Raise 60001, "JSON.GetObject", "Expecting " & EOO & ", received " & Mid(gStr, gPos, 1)
    End If
    
End Function

Private Function GetArray() As Collection
    Dim c As Collection
    Set c = New Collection
    SkipWhiteSpaces
    If Mid(gStr, gPos, 1) <> BOA Then
         Err.Raise 60001, "JSON.GetArray", "Expecting " & BOA & ", received " & Mid(gStr, gPos, 1)
    End If
    gPos = gPos + 1
    SkipWhiteSpaces
    If Mid(gStr, gPos, 1) = EOA Then 'empty array
        Set GetArray = c
        gPos = gPos + 1
        Exit Function
    End If

    Do
        c.Add GetItem
    Loop While HasMore
    
    SkipWhiteSpaces
    If Mid(gStr, gPos, 1) = EOA Then
        Set GetArray = c
        gPos = gPos + 1
    Else
        Err.Raise 60001, "JSON.GetArray", "Expecting " & EOA & ", received " & Mid(gStr, gPos, 1)
    End If

End Function

Private Sub AddMember(d As Dictionary)
    SkipWhiteSpaces
    Dim strName As String
    If Mid(gStr, gPos, 1) <> Chr(34) Then
        Err.Raise 60001, "JSON.AddMember", "Expecting " & Chr(34) & " , received " & Mid(gStr, gPos, 1)
    End If
    strName = GetName()
    If d.Exists(strName) Then
        Err.Raise 60001, "JSON.AddMember", "Name already exists: " & strName
    End If
    SkipWhiteSpaces
    If Mid(gStr, gPos, 1) <> NVS Then
        Err.Raise 60001, "JSON.AddMember", "Expecting " & NVS & " , received " & Mid(gStr, gPos, 1)
    End If
    gPos = gPos + 1
    d.Add strName, GetItem()
    SkipWhiteSpaces
End Sub

Private Function GetName() As String
    GetName = GetString()
End Function
Private Function GetString() As String
    Dim l As Long
    l = gPos + 1
    While Mid(gStr, l, 1) <> Chr(34) And l <= Len(gStr)
        l = l + 1
    Wend
    If Mid(gStr, l, 1) <> Chr(34) Then
        Err.Raise 60001, "JSON.GetName", "Expecting " & Chr(34) & " , received " & Mid(gStr, gPos, 1)
    End If
    GetString = UnescapeText(Mid(gStr, gPos + 1, l - gPos - 1))
    gPos = l + 1
End Function

Private Function GetNonString() As String
    Dim l As Long
    l = gPos
    While Mid(gStr, l, 1) <> EOO And Mid(gStr, l, 1) <> EOA And Mid(gStr, l, 1) <> MS And l <= Len(gStr)
        l = l + 1
    Wend
    If Mid(gStr, l, 1) <> EOO And Mid(gStr, l, 1) <> EOA And Mid(gStr, l, 1) <> MS Then
        Err.Raise 60001, "JSON.GetName", "Expecting " & EOO & " or " & EOA & " or " & MS & " , received " & Mid(gStr, gPos, 1)
    End If
    GetNonString = Trim(Mid(gStr, gPos, l - gPos))
    gPos = l
End Function

Private Function GetItem() As Variant
    SkipWhiteSpaces
    Select Case (Mid(gStr, gPos, 1))
    Case BOO: Set GetItem = GetObject
    Case BOA: Set GetItem = GetArray
    Case Chr(34): GetItem = GetString
    Case Else:
        Dim strVal As String
        strVal = GetNonString
        If strVal = "true" Then
            GetItem = True
        ElseIf strVal = "null" Then
            GetItem = Null
        ElseIf strVal = "false" Then
            GetItem = False
        ElseIf IsNumeric(strVal) Then
            GetItem = CDbl(strVal)
        Else
            Err.Raise 60001, "JSON.GetItem", "Uexpected value " & strVal
        End If
    End Select
End Function
Private Function HasMore() As Boolean
    SkipWhiteSpaces
    If Mid(gStr, gPos, 1) = "," Then
        HasMore = True
        gPos = gPos + 1
    Else
        HasMore = False
    End If
End Function


Private Sub SkipWhiteSpaces()
    While Trim(Mid(gStr, gPos, 1)) = vbNullString And gPos <= Len(gStr)
        gPos = gPos + 1
    Wend
End Sub

Function UnescapeText(strEscapedText As String) As String

    Dim i As Integer
    Dim s() As String
    Dim hs As String, ls As String
    ReDim s(Len(strEscapedText)) 'unescaped text is always shorter
    For i = 1 To Len(strEscapedText)
        If Mid(strEscapedText, i, 1) = "\" Then
            If i + 1 > Len(strEscapedText) Then
                Err.Raise 60001, "JSON.UnescapeText", "Unexpected \ at the end of text"
            End If
            Select Case (Mid(strEscapedText, i + 1, 1))
            Case Chr(34), "/", "\":
                s(i) = Mid(strEscapedText, i + 1, 1)
                i = i + 1
            Case "b":
                s(i) = Chr(8)
                i = i + 1
            Case "f":
                s(i) = Chr(12)
                i = i + 1
            Case "n":
                s(i) = Chr(10)
                i = i + 1
            Case "r":
                s(i) = Chr(13)
                i = i + 1
            Case "t":
                s(i) = Chr(9)
                i = i + 1
            Case "u":
                If i + 5 > Len(strEscapedText) Then
                    Err.Raise 60001, "JSON.UnescapeText", "Unexpected sequence at the end of text: " & Mid(strEscapedText, i, 5)
                End If
                hs = "&H" & Mid(strEscapedText, i + 2, 4)
                If Not IsNumeric(hs) Then
                    Err.Raise 60001, "JSON.UnescapeText", "Invalid unicode escape : " & Mid(strEscapedText, i, 6)
                End If
                If CLng(hs) < MIN_HSG Or CLng(hs) > MAX_LSG Then 'not surrogate pair
                    s(i) = Application.WorksheetFunction.Unichar(CDbl(hs))
                    i = i + 5
                Else
                    If i + 11 > Len(strEscapedText) Then
                        Err.Raise 60001, "JSON.UnescapeText", "Invalid unicode escape at the end of text : " & Mid(strEscapedText, i, 255)
                    End If
                    ls = "&H" & Mid(strEscapedText, i + 8, 4)
                    If Mid(strEscapedText, i + 6, 2) <> "\u" Or Not IsNumeric(ls) Then
                        Err.Raise 60001, "JSON.UnescapeText", "Invalid Low Surrogate: " & Mid(strEscapedText, i, 12)
                    End If
                    If CLng(ls) < MIN_LSG Or CLng(ls) > MAX_LSG Then
                        Err.Raise 60001, "JSON.UnescapeText", "Low Surrogate Out of Range: " & Mid(strEscapedText, i, 12)
                    End If
                    s(i) = Application.WorksheetFunction.Unichar(&H10000 + (CLng(hs) - MIN_HSG) * &H400 + (CLng(ls) - MIN_LSG))
                    i = i + 11
                End If
            Case Else:
                Err.Raise 60001, "JSON.UnescapeText", "Invalid escape sequence: " & Mid(strEscapedText, i, 2)
            End Select
        Else
            s(i) = Mid(strEscapedText, i, 1)
        End If
    Next
    UnescapeText = Join(s, "")
End Function
```

### テスト

テスト用にはpythonのjson.dumpsが便利なので適当なjsonオブジェクトを作り文字列にする
```python
import json
def main():
    d={"UTF-16のサロゲートペアを含む文字列": "アスキー(abc12345%^&*X), サロゲートペア(𪚥𩸽)",
       "配列": [1,2,3,{"配列内オブジェクト": "配列内オブジェクトの値"}]}
    print(json.dumps(d))
```

ExcelのセルA1に文字列を張り付けて、以下のテストを実行する
```vb
Sub Test()
    Dim obj As Object
    Set obj = Parse(Sheet1.Range("a1"))
    Sheet1.Range("a2") = obj("UTF-16のサロゲートペアを含む文字列")
    Sheet1.Range("a3") = obj("配列")(4)("配列内オブジェクト")
End Sub
```

結果
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3972538/ab953237-cc23-0e5f-cb83-9c42d849cdd2.png)