[VBA] 轉換 Json 字串到 Excel 表格

前篇：[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)))

我自己之後會持續使用自己程式碼，擴大支援範圍。