前篇：[VBA] 抓取 Json 檔案轉入 Excel
前篇的 Json 字串解析，是從 GitHub 上抓的，別人的程式碼用一陣子總覺得全身不舒服，前陣子要處理 OCPP 的 Json 字串時，就自己寫一個。
呼叫範例：
Sub CommandOpenFile(ByVal strCommand)
Set tSheets = ThisWorkbook.Sheets(strCommand)
strFileName = ThisWorkbook.Path & "\ocpp.log"
strBody = myGetStringFile(strFileName)
arrBody = Split(strBody, vbLf)
ubl = UBound(arrBody)
iRow = 1
For ibl = 0 To ubl
nLoc = InStr(arrBody(ibl), StringFormat(",{0}{1}{0},{", """", strCommand))
If nLoc > 0 Then
sLoc = InStr(nLoc + 1, arrBody(ibl), "{")
eLoc = Len(arrBody(ibl)) - 1
strValue = Mid(arrBody(ibl), sLoc, eLoc - sLoc + 1)
Set pJson = ParseJson(strValue)
If iRow = 1 Then
uCol = pJson.Count
arrCol = pJson.Keys
For iCol = 1 To uCol
tSheets.Cells(iRow, 1 + iCol) = arrCol(iCol - 1)
Next
iRow = iRow + 1
End If
For iCol = 1 To uCol
tSheets.Cells(iRow, 1 + iCol) = pJson(arrCol(iCol - 1))
Next
iRow = iRow + 1
Set pJson = Nothing
End If
Next
End Sub
我把我的 Json 解析獨立放在一個模組內，可參考下方網址
modJsonTool.bas: https://1drv.ms/u/s!AqdV_QuSGVQUy2eZgQaLJJb2BNbz?e=7xFSKW
這段的目的是我的 OCPP.log 是一個通訊過程的紀錄檔，裡面有多段的 Json 字串，大部分的指令所形成的 Json 都比較簡單，就用一個通用的副程式解析，把相同指令的 Json 解析都扔到相同的頁籤。
OCPP 內比較複雜的類似 MetaValues 指令，因為回傳的是樹狀結構，不是列狀 (Row) ，所以要挑自己要留的欄位轉到 Excel 內，就單獨另外寫一個 Sub 處理。
Json 解析我參照前篇的架構，屬於樹狀的資料 (以 {…} 包括) 用 Dictionary 去處理，屬於陣列的資料 (以 […] 包括) ，用 Collection 處理，解析的程式碼就用遞迴處理，所以主要的只有一個函數：
Function ParseJson(ByVal strJson As String, Optional ByVal rootDelimiter As Variant)
JsonDelimiterInit
ubd = UBound(jsonDelimiter)
ReDim arrIndex(ubd)
ReDim colTemp(ubd) As New Collection
fmtKeepName = "(($VbaJson${0}${1}${2}$))"
fmtKeepLeft = 11
rtnValue = Empty
strJson = TrimEx(strJson)
lenJson = Len(strJson)
pbd = -1
startLoc = 0
Do
nowIndex = lenJson + 1
nbd = -1
For ibd = 0 To ubd
arrIndex(ibd) = InStr(startLoc + 1, strJson, jsonDelimiter(ibd)(0))
If arrIndex(ibd) > 0 And nowIndex > arrIndex(ibd) Then
nowIndex = arrIndex(ibd)
nbd = ibd
End If
Next
If nbd = -1 Then
' 沒有括號裡面開始解析內容
Exit Do
Else
' 字串的引號裡面會不會有括號？
startLoc = arrIndex(nbd)
endIndex = FoundBlockEndIndex(strJson, jsonDelimiter(nbd), startLoc)
If endIndex > 0 Then
pbd = nbd
colIndex = colTemp(nbd).Count + 1
Select Case jsonDelimiter(nbd)(0)
Case "{"
strObjectName = StringFormat(fmtKeepName, "Object", nbd, colIndex)
Case "["
strObjectName = StringFormat(fmtKeepName, "Array", nbd, colIndex)
Case Else
Err.Raise &H80000001, , "Json 字串解析格式錯誤"
End Select
subJson = Mid(strJson, startLoc + 1, endIndex - startLoc - 1)
strJson = Replace(strJson, StringFormat("{1}{0}{2}", subJson, jsonDelimiter(nbd)(0), jsonDelimiter(nbd)(1)), strObjectName)
colTemp(nbd).Add ParseJson(subJson, jsonDelimiter(nbd))
Else
Err.Raise &H80000002, , "Json 字串缺括號 " & jsonDelimiter(nbd)(1) & "，字串內容為 " & strJson
Exit Do
End If
End If
Loop
If lenJson > 0 Then
' 回傳物件
If IsMissing(rootDelimiter) Then
Set rtnValue = colTemp(pbd)(colTemp(pbd).Count)
Else
nowDelimiter = rootDelimiter(0)
Select Case nowDelimiter
Case "{"
' Set rtnValue = New Dictionary ' 需在 選單 工具 設定引用項目 引用 Microsoft Scripting Runtime ，使用其中 Dictionary 類別
Set rtnValue = CreateScriptingDictionary()
Case "["
Set rtnValue = New Collection
End Select
' 解析內容
arrItems = Split(strJson, ",")
ubi = UBound(arrItems)
For ibi = 0 To ubi
arrItems(ibi) = TrimEx(arrItems(ibi))
Select Case nowDelimiter
Case "{"
itemRow = Split(arrItems(ibi), ":")
ubr = UBound(itemRow)
If ubr > 1 Then
For ibr = 2 To ubr
itemRow(1) = itemRow(1) & ":" & itemRow(ibr)
Next
End If
For ibr = 0 To 1
itemRow(ibr) = TrimEx(itemRow(ibr))
Next
itemKey = TrimEx(itemRow(0), TES_SepcialAdd, , """'")
strItem = itemRow(1)
Case "["
itemKey = CStr(ibi + 2)
strItem = arrItems(ibi)
End Select
If InStr(strItem, Left(fmtKeepName, fmtKeepLeft)) >= 1 Then
arrRow = Split(strItem, "$")
Set itemValue = colTemp(CLng(arrRow(3)))(CLng(arrRow(4)))
Else
strValue = TrimEx(strItem, TES_SepcialAdd, , """'")
If Len(strValue) < Len(strItem) Then
itemValue = strValue
Else
itemValue = CVariant(strValue)
End If
End If
Select Case nowDelimiter
Case "{"
rtnValue.Add itemKey, itemValue
Case "["
rtnValue.Add itemValue, itemKey
End Select
Next
End If
End If
Set ParseJson = rtnValue
Set rtnValue = Nothing
For ibd = 0 To ubd
Set colTemp(ibd) = Nothing
Next
End Function
每一層物件對應到 Json 每一層。
由於用遞迴函數，如果碰上我還沒遭遇過的特殊字串，可能會卡在裡面，建議在這個函數裡面加 DoEvents ，若遭遇到無窮迴圈時，可以透過除錯模式跳出，加入特殊字串處理。
GitHub 範例要求要在 VBA 專案參照物件 (提早連結)，好處是執行效能比較快，缺點是不熟的人不會處理，特別是 VBA 的安全信任一直調整，所以我改成延後連結的方式處理：
Function CreateScriptingDictionary() As Object
Set CreateScriptingDictionary = CreateObject("Scripting.Dictionary")
End Function目前遭遇過特殊字元已經納入處理的有這個陣列：
If Not IsArray(jsonEscape) Then jsonEscape = Array(Split("\""|\\|\/|\b|\f|\n|\r|\t", "|"), Array("""", "\", "/", Chr(8), Chr(12), Chr(13), Chr(10), Chr(9)))我自己之後會持續使用自己程式碼，擴大支援範圍。
鄭子璉 