Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Option Explicit
- Sub JsonTest()
- Dim strJsonString As String
- Dim varJson As Variant
- Dim strState As String
- Dim varItem As Variant
- ' parse JSON string to object
- ' root element can be the object {} or the array []
- strJsonString = "{""a"":[{}, 0, ""value"", [{""stuff"":""content""}]], b:null}"
- ParseJson strJsonString, varJson, strState
- ' checking the structure step by step
- Select Case False ' if any of the checks is False, the sequence is interrupted
- Case IsObject(varJson) ' if root JSON element is object {},
- Case varJson.Exists("a") ' having property a,
- Case IsArray(varJson("a")) ' which is array,
- Case UBound(varJson("a")) >= 3 ' having not less than 4 elements,
- Case IsArray(varJson("a")(3)) ' where forth element is array,
- Case UBound(varJson("a")(3)) = 0 ' having the only element,
- Case IsObject(varJson("a")(3)(0)) ' which is object,
- Case varJson("a")(3)(0).Exists("stuff") ' having property stuff,
- Case Else
- MsgBox "Check the structure step by step" & vbCrLf & varJson("a")(3)(0)("stuff") ' then show the value of the last one property.
- End Select
- ' direct access to the property if sure of structure
- MsgBox "Direct access to the property" & vbCrLf & varJson.Item("a")(3)(0).Item("stuff") ' content
- ' traversing each element in array
- For Each varItem In varJson("a")
- ' show the structure of the element
- MsgBox "The structure of the element:" & vbCrLf & BeautifyJson(varItem)
- Next
- ' show the full structure starting from root element
- MsgBox "The full structure starting from root element:" & vbCrLf & BeautifyJson(varJson)
- End Sub
- Sub BeautifyTest()
- ' put sourse JSON string to "desktop\source.json" file
- ' processed JSON will be saved to "desktop\result.json" file
- Dim strDesktop As String
- Dim strJsonString As String
- Dim varJson As Variant
- Dim strState As String
- Dim strResult As String
- Dim lngIndent As Long
- strDesktop = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
- strJsonString = ReadTextFile(strDesktop & "\source.json", -2)
- ParseJson strJsonString, varJson, strState
- If strState <> "Error" Then
- strResult = BeautifyJson(varJson)
- WriteTextFile strResult, strDesktop & "\result.json", -1
- End If
- CreateObject("WScript.Shell").PopUp strState, 1, , 64
- End Sub
- Sub ParseJson(ByVal strContent As String, varJson As Variant, strState As String)
- ' strContent - source JSON string
- ' varJson - created object or array to be returned as result
- ' strState - Object|Array|Error depending on processing to be returned as state
- Dim objTokens As Object
- Dim lngTokenId As Long
- Dim objRegEx As Object
- Dim bMatched As Boolean
- Set objTokens = CreateObject("Scripting.Dictionary")
- lngTokenId = 0
- Set objRegEx = CreateObject("VBScript.RegExp")
- With objRegEx
- ' specification http://www.json.org/
- .Global = True
- .MultiLine = True
- .IgnoreCase = True
- .Pattern = """(?:\\""|[^""])*""(?=\s*(?:,|\:|\]|\}))"
- Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "str"
- .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)e(?:[+-])?\d+(?=\s*(?:,|\]|\}))"
- Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "num"
- .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)(?=\s*(?:,|\]|\}))"
- Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "num"
- .Pattern = "\b(?:true|false|null)(?=\s*(?:,|\]|\}))"
- Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "cst"
- .Pattern = "\b[A-Za-z_]\w*(?=\s*\:)" ' unspecified name without quotes
- Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "nam"
- .Pattern = "\s"
- strContent = .Replace(strContent, "")
- .MultiLine = False
- Do
- bMatched = False
- .Pattern = "<\d+(?:str|nam)>\:<\d+(?:str|num|obj|arr|cst)>"
- Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "prp"
- .Pattern = "\{(?:<\d+prp>(?:,<\d+prp>)*)?\}"
- Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "obj"
- .Pattern = "\[(?:<\d+(?:str|num|obj|arr|cst)>(?:,<\d+(?:str|num|obj|arr|cst)>)*)?\]"
- Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "arr"
- Loop While bMatched
- .Pattern = "^<\d+(?:obj|arr)>$" ' unspecified top level array
- If Not (.test(strContent) And objTokens.Exists(strContent)) Then
- varJson = Null
- strState = "Error"
- Else
- Retrieve objTokens, objRegEx, strContent, varJson
- strState = IIf(IsObject(varJson), "Object", "Array")
- End If
- End With
- End Sub
- Sub Tokenize(objTokens, objRegEx, strContent, lngTokenId, bMatched, strType)
- Dim strKey As String
- Dim strRes As String
- Dim lngCopyIndex As Long
- Dim objMatch As Object
- strRes = ""
- lngCopyIndex = 1
- With objRegEx
- For Each objMatch In .Execute(strContent)
- strKey = "<" & lngTokenId & strType & ">"
- bMatched = True
- With objMatch
- objTokens(strKey) = .Value
- strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey
- lngCopyIndex = .FirstIndex + .Length + 1
- End With
- lngTokenId = lngTokenId + 1
- Next
- strContent = strRes & Mid(strContent, lngCopyIndex, Len(strContent) - lngCopyIndex + 1)
- End With
- End Sub
- Sub Retrieve(objTokens, objRegEx, strTokenKey, varTransfer)
- Dim strContent As String
- Dim strType As String
- Dim objMatches As Object
- Dim objMatch As Object
- Dim strName As String
- Dim varValue As Variant
- Dim objArrayElts As Object
- strType = Left(Right(strTokenKey, 4), 3)
- strContent = objTokens(strTokenKey)
- With objRegEx
- .Global = True
- Select Case strType
- Case "obj"
- .Pattern = "<\d+\w{3}>"
- Set objMatches = .Execute(strContent)
- Set varTransfer = CreateObject("Scripting.Dictionary")
- For Each objMatch In objMatches
- Retrieve objTokens, objRegEx, objMatch.Value, varTransfer
- Next
- Case "prp"
- .Pattern = "<\d+\w{3}>"
- Set objMatches = .Execute(strContent)
- Retrieve objTokens, objRegEx, objMatches(0).Value, strName
- Retrieve objTokens, objRegEx, objMatches(1).Value, varValue
- If IsObject(varValue) Then
- Set varTransfer(strName) = varValue
- Else
- varTransfer(strName) = varValue
- End If
- Case "arr"
- .Pattern = "<\d+\w{3}>"
- Set objMatches = .Execute(strContent)
- Set objArrayElts = CreateObject("Scripting.Dictionary")
- For Each objMatch In objMatches
- Retrieve objTokens, objRegEx, objMatch.Value, varValue
- If IsObject(varValue) Then
- Set objArrayElts(objArrayElts.Count) = varValue
- Else
- objArrayElts(objArrayElts.Count) = varValue
- End If
- varTransfer = objArrayElts.Items
- Next
- Case "nam"
- varTransfer = strContent
- Case "str"
- varTransfer = Mid(strContent, 2, Len(strContent) - 2)
- varTransfer = Replace(varTransfer, "\""", """")
- varTransfer = Replace(varTransfer, "\\", "\")
- varTransfer = Replace(varTransfer, "\/", "/")
- varTransfer = Replace(varTransfer, "\b", Chr(8))
- varTransfer = Replace(varTransfer, "\f", Chr(12))
- varTransfer = Replace(varTransfer, "\n", vbLf)
- varTransfer = Replace(varTransfer, "\r", vbCr)
- varTransfer = Replace(varTransfer, "\t", vbTab)
- .Global = False
- .Pattern = "\\u[0-9a-fA-F]{4}"
- Do While .test(varTransfer)
- varTransfer = .Replace(varTransfer, ChrW(("&H" & Right(.Execute(varTransfer)(0).Value, 4)) * 1))
- Loop
- Case "num"
- varTransfer = Evaluate(strContent)
- Case "cst"
- Select Case LCase(strContent)
- Case "true"
- varTransfer = True
- Case "false"
- varTransfer = False
- Case "null"
- varTransfer = Null
- End Select
- End Select
- End With
- End Sub
- Function BeautifyJson(varJson As Variant) As String
- Dim strResult As String
- Dim lngIndent As Long
- BeautifyJson = ""
- lngIndent = 0
- BeautyTraverse BeautifyJson, lngIndent, varJson, vbTab, 1
- End Function
- Sub BeautyTraverse(strResult As String, lngIndent As Long, varElement As Variant, strIndent As String, lngStep As Long)
- Dim arrKeys() As Variant
- Dim lngIndex As Long
- Dim strTemp As String
- Select Case VarType(varElement)
- Case vbObject
- If varElement.Count = 0 Then
- strResult = strResult & "{}"
- Else
- strResult = strResult & "{" & vbCrLf
- lngIndent = lngIndent + lngStep
- arrKeys = varElement.Keys
- For lngIndex = 0 To UBound(arrKeys)
- strResult = strResult & String(lngIndent, strIndent) & """" & arrKeys(lngIndex) & """" & ": "
- BeautyTraverse strResult, lngIndent, varElement(arrKeys(lngIndex)), strIndent, lngStep
- If Not (lngIndex = UBound(arrKeys)) Then strResult = strResult & ","
- strResult = strResult & vbCrLf
- Next
- lngIndent = lngIndent - lngStep
- strResult = strResult & String(lngIndent, strIndent) & "}"
- End If
- Case Is >= vbArray
- If UBound(varElement) = -1 Then
- strResult = strResult & "[]"
- Else
- strResult = strResult & "[" & vbCrLf
- lngIndent = lngIndent + lngStep
- For lngIndex = 0 To UBound(varElement)
- strResult = strResult & String(lngIndent, strIndent)
- BeautyTraverse strResult, lngIndent, varElement(lngIndex), strIndent, lngStep
- If Not (lngIndex = UBound(varElement)) Then strResult = strResult & ","
- strResult = strResult & vbCrLf
- Next
- lngIndent = lngIndent - lngStep
- strResult = strResult & String(lngIndent, strIndent) & "]"
- End If
- Case vbInteger, vbLong, vbSingle, vbDouble
- strResult = strResult & varElement
- Case vbNull
- strResult = strResult & "Null"
- Case vbBoolean
- strResult = strResult & IIf(varElement, "True", "False")
- Case Else
- strTemp = Replace(varElement, "\""", """")
- strTemp = Replace(strTemp, "\", "\\")
- strTemp = Replace(strTemp, "/", "\/")
- strTemp = Replace(strTemp, Chr(8), "\b")
- strTemp = Replace(strTemp, Chr(12), "\f")
- strTemp = Replace(strTemp, vbLf, "\n")
- strTemp = Replace(strTemp, vbCr, "\r")
- strTemp = Replace(strTemp, vbTab, "\t")
- strResult = strResult & """" & strTemp & """"
- End Select
- End Sub
- Function ReadTextFile(strPath As String, lngFormat As Long) As String
- ' lngFormat -2 - System default, -1 - Unicode, 0 - ASCII
- With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 1, False, lngFormat)
- ReadTextFile = ""
- If Not .AtEndOfStream Then ReadTextFile = .ReadAll
- .Close
- End With
- End Function
- Sub WriteTextFile(strContent As String, strPath As String, lngFormat As Long)
- With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 2, True, lngFormat)
- .Write (strContent)
- .Close
- End With
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement