LoginSignup
2
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@Oeuf

VBAでJSON文字列を読み込む

Posted at

課題

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

実装

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

ソースコード

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オブジェクトを作り文字列にする

import json
def main():
    d={"UTF-16のサロゲートペアを含む文字列": "アスキー(abc12345%^&*X), サロゲートペア(𪚥𩸽)",
       "配列": [1,2,3,{"配列内オブジェクト": "配列内オブジェクトの値"}]}
    print(json.dumps(d))

ExcelのセルA1に文字列を張り付けて、以下のテストを実行する

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

2
1
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
2
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?