diff --git a/JsonConverter.bas b/JsonConverter.bas index 876b865..2369c3e 100644 --- a/JsonConverter.bas +++ b/JsonConverter.bas @@ -155,10 +155,15 @@ Private Type json_Options ' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson EscapeSolidus As Boolean End Type + +Private json_Indentation As String +Private json_InnerIndentation As String +Private json_PrettyPrint As Boolean + Public JsonOptions As json_Options ' ============================================= ' -' Public Methods +' Public Methods - Json ' ============================================= ' '' @@ -196,266 +201,59 @@ End Function ' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string ' @return {String} '' -Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String - Dim json_Buffer As String - Dim json_BufferPosition As Long - Dim json_BufferLength As Long - Dim json_Index As Long - Dim json_LBound As Long - Dim json_UBound As Long - Dim json_IsFirstItem As Boolean - Dim json_Index2D As Long - Dim json_LBound2D As Long - Dim json_UBound2D As Long - Dim json_IsFirstItem2D As Boolean - Dim json_Key As Variant - Dim json_Value As Variant - Dim json_DateStr As String - Dim json_Converted As String - Dim json_SkipItem As Boolean - Dim json_PrettyPrint As Boolean - Dim json_Indentation As String - Dim json_InnerIndentation As String - - json_LBound = -1 - json_UBound = -1 - json_IsFirstItem = True - json_LBound2D = -1 - json_UBound2D = -1 - json_IsFirstItem2D = True - json_PrettyPrint = Not IsMissing(Whitespace) - - Select Case VBA.VarType(JsonValue) +Public Function ConvertToJson(ByVal jsonValue As Variant, Optional ByVal whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String + On Error GoTo ExitHere + + 'Intialize + json_PrettyPrint = Not IsMissing(whitespace) + + Select Case VBA.VarType(jsonValue) Case VBA.vbNull ConvertToJson = "null" - Case VBA.vbDate - ' Date - json_DateStr = ConvertToIso(VBA.CDate(JsonValue)) - - ConvertToJson = """" & json_DateStr & """" - Case VBA.vbString - ' String (or large number encoded as string) - If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then - ConvertToJson = JsonValue + + Case VBA.vbDate 'Date + ConvertToJson = """" & ConvertToIso(VBA.CDate(jsonValue)) & """" + + Case VBA.vbString 'String (or large number encoded as string) + If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(jsonValue) Then + ConvertToJson = jsonValue Else - ConvertToJson = """" & json_Encode(JsonValue) & """" + ConvertToJson = """" & json_Encode(jsonValue) & """" End If + Case VBA.vbBoolean - If JsonValue Then + If jsonValue Then ConvertToJson = "true" Else ConvertToJson = "false" End If + Case VBA.vbArray To VBA.vbArray + VBA.vbByte - If json_PrettyPrint Then - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) - json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace) - Else - json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) - json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace) - End If - End If - - ' Array - json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength - - On Error Resume Next - - json_LBound = LBound(JsonValue, 1) - json_UBound = UBound(JsonValue, 1) - json_LBound2D = LBound(JsonValue, 2) - json_UBound2D = UBound(JsonValue, 2) - - If json_LBound >= 0 And json_UBound >= 0 Then - For json_Index = json_LBound To json_UBound - If json_IsFirstItem Then - json_IsFirstItem = False - Else - ' Append comma to previous line - json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength - End If - - If json_LBound2D >= 0 And json_UBound2D >= 0 Then - ' 2D Array - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - End If - json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength - - For json_Index2D = json_LBound2D To json_UBound2D - If json_IsFirstItem2D Then - json_IsFirstItem2D = False - Else - json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength - End If - - json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) - - ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null - If json_Converted = "" Then - ' (nest to only check if converted = "") - If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then - json_Converted = "null" - End If - End If - - If json_PrettyPrint Then - json_Converted = vbNewLine & json_InnerIndentation & json_Converted - End If - - json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength - Next json_Index2D - - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - End If - - json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength - json_IsFirstItem2D = True - Else - ' 1D Array - json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1) - - ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null - If json_Converted = "" Then - ' (nest to only check if converted = "") - If json_IsUndefined(JsonValue(json_Index)) Then - json_Converted = "null" - End If - End If - - If json_PrettyPrint Then - json_Converted = vbNewLine & json_Indentation & json_Converted - End If - - json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength - End If - Next json_Index - End If - - On Error GoTo 0 - - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) - Else - json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) - End If - End If - - json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength - - ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) - - ' Dictionary or Collection - Case VBA.vbObject - If json_PrettyPrint Then - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) - Else - json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) - End If - End If - - ' Dictionary - If VBA.TypeName(JsonValue) = "Dictionary" Then - json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength - For Each json_Key In JsonValue.Keys - ' For Objects, undefined (Empty/Nothing) is not added to object - json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1) - If json_Converted = "" Then - json_SkipItem = json_IsUndefined(JsonValue(json_Key)) - Else - json_SkipItem = False - End If - - If Not json_SkipItem Then - If json_IsFirstItem Then - json_IsFirstItem = False - Else - json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength - End If - - If json_PrettyPrint Then - json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted - Else - json_Converted = """" & json_Key & """:" & json_Converted - End If - - json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength - End If - Next json_Key - - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) - Else - json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) - End If - End If - - json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength - - ' Collection - ElseIf VBA.TypeName(JsonValue) = "Collection" Then - json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength - For Each json_Value In JsonValue - If json_IsFirstItem Then - json_IsFirstItem = False - Else - json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength - End If - - json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) - - ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null - If json_Converted = "" Then - ' (nest to only check if converted = "") - If json_IsUndefined(json_Value) Then - json_Converted = "null" - End If - End If - - If json_PrettyPrint Then - json_Converted = vbNewLine & json_Indentation & json_Converted - End If - - json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength - Next json_Value - - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) - Else - json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) - End If - End If - - json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength - End If - - ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) - Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal - ' Number (use decimals for numbers) - ConvertToJson = VBA.Replace(JsonValue, ",", ".") + ConvertToJson = json_ConvertArray(jsonValue, whitespace, json_CurrentIndentation) + + Case VBA.vbObject ' Dictionary or Collection + ConvertToJson = json_ConvertObject(jsonValue, whitespace, json_CurrentIndentation) + + Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal ' Number (use decimals for numbers) + ConvertToJson = VBA.Replace(jsonValue, ",", ".") + Case Else ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType ' Use VBA's built-in to-string On Error Resume Next - ConvertToJson = JsonValue + ConvertToJson = jsonValue On Error GoTo 0 End Select + +ExitHere: + 'Reset module level variables for next run + json_Indentation = "" + json_InnerIndentation = "" + json_PrettyPrint = False End Function ' ============================================= ' -' Private Functions +' Private Functions - ParseJson ' ============================================= ' Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary @@ -482,9 +280,9 @@ Private Function json_ParseObject(json_String As String, ByRef json_Index As Lon json_Key = json_ParseKey(json_String, json_Index) json_NextChar = json_Peek(json_String, json_Index) If json_NextChar = "[" Or json_NextChar = "{" Then - Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) + Set json_ParseObject.item(json_Key) = json_ParseValue(json_String, json_Index) Else - json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) + json_ParseObject.item(json_Key) = json_ParseValue(json_String, json_Index) End If Loop End If @@ -859,6 +657,348 @@ Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_Buf End If End Function +' ============================================= ' +' Private Functions - ConvertJSON +' ============================================= ' + +Private Function json_ConvertArray(ByVal jsonValue As Variant, _ + ByVal whitespace As Variant, _ + ByVal currentIndentation As Long) As String + If json_IsArray2D(jsonValue) Then + json_ConvertArray = json_Convert2DArray(jsonValue, whitespace, currentIndentation) + Else + json_ConvertArray = json_Convert1DArray(jsonValue, whitespace, currentIndentation) + End If +End Function + +Private Function json_IsArray2D(inputArray As Variant) As Boolean + Dim lbound2D As Long + Dim ubound2D As Long + + On Error Resume Next + + 'Initialize + lbound2D = -1 + ubound2D = -1 + + 'Obtain dimension of array + lbound2D = LBound(inputArray, 1) + ubound2D = UBound(inputArray, 2) + + On Error GoTo 0 + + json_IsArray2D = (lbound2D >= 0 And ubound2D >= 0) +End Function + +Private Function json_Convert1DArray(ByVal jsonValue As Variant, _ + ByVal whitespace As Variant, _ + ByVal currentIndentation As Long) As String + Dim buffer As String + Dim bufferPosition As Long + Dim bufferLength As Long + + Dim converted As String + Dim isFirstItem As Boolean + Dim i As Long + + 'Intialize + isFirstItem = True + + 'Pretty print formatting before array conversion - setting indentation and inner indentation + Call json_PrettyPrint_PreConvert(whitespace, currentIndentation) + + 'Open "[" + Call json_BufferAppend(buffer, "[", bufferPosition, bufferLength) + + For i = LBound(jsonValue, 1) To UBound(jsonValue, 1) + If isFirstItem Then + isFirstItem = False + Else + 'Append comma to previous line + Call json_BufferAppend(buffer, ",", bufferPosition, bufferLength) + End If + + '1D Array + converted = ConvertToJson(jsonValue(i), whitespace, currentIndentation + 1) + + 'For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(jsonValue(i)) Then + converted = "null" + End If + End If + + If json_PrettyPrint Then + converted = vbNewLine & json_Indentation & converted + End If + + Call json_BufferAppend(buffer, converted, bufferPosition, bufferLength) + Next i + + 'Pretty print formatting after array conversion + Call json_PrettyPrint_PostConvert(whitespace, currentIndentation, buffer, bufferPosition, bufferLength) + + 'Close "]" + Call json_BufferAppend(buffer, json_Indentation & "]", bufferPosition, bufferLength) + + 'Return result + json_Convert1DArray = json_BufferToString(buffer, bufferPosition) +End Function + +Private Function json_Convert2DArray(ByVal jsonValue As Variant, _ + ByVal whitespace As Variant, _ + ByVal currentIndentation As Long) As String + Dim buffer As String + Dim bufferPosition As Long + Dim bufferLength As Long + + Dim converted As String + Dim isFirstItem As Boolean + Dim isFirstItem2D As Boolean + Dim i As Long + Dim j As Long + + 'Intialize + isFirstItem = True + isFirstItem2D = True + + 'Pretty print formatting before array conversion - setting indentation and inner indentation + Call json_PrettyPrint_PreConvert(whitespace, currentIndentation) + + 'Open "[" for dimension 1 + Call json_BufferAppend(buffer, "[", bufferPosition, bufferLength) + + For i = LBound(jsonValue, 1) To UBound(jsonValue, 1) + If isFirstItem Then + isFirstItem = False + Else + 'Append comma to previous line + Call json_BufferAppend(buffer, ",", bufferPosition, bufferLength) + End If + + 'Append a new line + If json_PrettyPrint Then + Call json_BufferAppend(buffer, vbNewLine, bufferPosition, bufferLength) + End If + + 'Open "[" for dimension 2 + Call json_BufferAppend(buffer, json_Indentation & "[", bufferPosition, bufferLength) + + For j = LBound(jsonValue, 2) To UBound(jsonValue, 2) + If isFirstItem2D Then + isFirstItem2D = False + Else + 'Append comma to previous line + Call json_BufferAppend(buffer, ",", bufferPosition, bufferLength) + End If + + converted = ConvertToJson(jsonValue(i, j), whitespace, currentIndentation + 2) + + 'For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(jsonValue(i, j)) Then + converted = "null" + End If + End If + + If json_PrettyPrint Then + converted = vbNewLine & json_InnerIndentation & converted + End If + + Call json_BufferAppend(buffer, converted, bufferPosition, bufferLength) + Next j + + If json_PrettyPrint Then + Call json_BufferAppend(buffer, vbNewLine, bufferPosition, bufferLength) + End If + + Call json_BufferAppend(buffer, json_Indentation & "]", bufferPosition, bufferLength) + + isFirstItem2D = True + Next i + + 'Pretty print formatting after array conversion + Call json_PrettyPrint_PostConvert(whitespace, currentIndentation, buffer, bufferPosition, bufferLength) + + 'Close "]" + Call json_BufferAppend(buffer, json_Indentation & "]", bufferPosition, bufferLength) + + 'Return result + json_Convert2DArray = json_BufferToString(buffer, bufferPosition) +End Function + +Private Function json_ConvertObject(ByVal jsonValue As Variant, _ + ByVal whitespace As Variant, _ + ByVal currentIndentation As Long) As String + Select Case VBA.TypeName(jsonValue) + Case "Dictionary" + json_ConvertObject = json_ConvertDictionary(jsonValue, whitespace, currentIndentation) + Case "Collection" + json_ConvertObject = json_ConvertCollection(jsonValue, whitespace, currentIndentation) + End Select +End Function + +Private Function json_ConvertDictionary(ByVal jsonValue As Variant, _ + ByVal whitespace As Variant, _ + ByVal currentIndentation As Long) As String + Dim buffer As String + Dim bufferPosition As Long + Dim bufferLength As Long + + Dim converted As String + Dim key As Variant + Dim skipItem As Boolean + Dim isFirstItem As Boolean + + 'Initialize + isFirstItem = True + + 'Pretty print format before convert dictionary - setting indentation + Call json_PrettyPrint_PreConvert(whitespace, currentIndentation) + + 'Open "{" + Call json_BufferAppend(buffer, "{", bufferPosition, bufferLength) + + For Each key In jsonValue.Keys + 'For Objects, undefined (Empty/Nothing) is not added to object + converted = ConvertToJson(jsonValue(key), whitespace, currentIndentation + 1) + + skipItem = IIf(converted = "", json_IsUndefined(jsonValue(key)), False) + + If skipItem Then + GoTo NextIterate + End If + + If isFirstItem Then + isFirstItem = False + Else + Call json_BufferAppend(buffer, ",", bufferPosition, bufferLength) + End If + + If json_PrettyPrint Then + converted = vbNewLine & json_Indentation & """" & key & """: " & converted + Else + converted = """" & key & """:" & converted + End If + + Call json_BufferAppend(buffer, converted, bufferPosition, bufferLength) +NextIterate: + Next key + + 'Pretty print format + Call json_PrettyPrint_PostConvert(whitespace, currentIndentation, buffer, bufferPosition, bufferLength) + + 'Close "{" + Call json_BufferAppend(buffer, json_Indentation & "}", bufferPosition, bufferLength) + + 'Return result + json_ConvertDictionary = json_BufferToString(buffer, bufferPosition) +End Function + +Private Function json_ConvertCollection(ByVal jsonValue As Variant, _ + ByVal whitespace As Variant, _ + ByVal currentIndentation As Long) As String + Dim buffer As String + Dim bufferPosition As Long + Dim bufferLength As Long + + Dim converted As String + Dim item As Variant + Dim isFirstItem As Boolean + + 'Initialize + isFirstItem = True + + 'Pretty print format before convert collection + Call json_PrettyPrint_PreConvert(whitespace, currentIndentation) + + 'Open "[" + Call json_BufferAppend(buffer, "[", bufferPosition, bufferLength) + + For Each item In jsonValue + If isFirstItem Then + isFirstItem = False + Else + Call json_BufferAppend(buffer, ",", bufferPosition, bufferLength) + End If + + converted = ConvertToJson(item, whitespace, currentIndentation + 1) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(item) Then + converted = "null" + End If + End If + + If json_PrettyPrint Then + converted = vbNewLine & json_Indentation & converted + End If + + Call json_BufferAppend(buffer, converted, bufferPosition, bufferLength) + Next item + + 'Pretty print format + Call json_PrettyPrint_PostConvert(whitespace, currentIndentation, buffer, bufferPosition, bufferLength) + + 'Close "]" + Call json_BufferAppend(buffer, json_Indentation & "]", bufferPosition, bufferLength) + + 'Return result + json_ConvertCollection = json_BufferToString(buffer, bufferPosition) +End Function + +' ============================================= ' +' Private Functions - PrettyPrint/Formatting +' ============================================= ' + +Private Sub json_PrettyPrint_PreConvert(ByVal whitespace As Variant, _ + ByVal currentIndentation As Long) + 'Reset values + If Not json_PrettyPrint Then + json_Indentation = "" + json_InnerIndentation = "" + Exit Sub + End If + + If VBA.VarType(whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(currentIndentation + 1, whitespace) + json_InnerIndentation = VBA.String$(currentIndentation + 2, whitespace) + Else + json_Indentation = VBA.Space$((currentIndentation + 1) * whitespace) + json_InnerIndentation = VBA.Space$((currentIndentation + 2) * whitespace) + End If +End Sub + +Private Sub json_PrettyPrint_PostConvert(ByVal whitespace As Variant, _ + ByVal currentIndentation As Long, _ + ByRef buffer As String, _ + ByRef bufferPosition As Long, _ + ByRef bufferLength As Long) + If Not json_PrettyPrint Then + json_Indentation = "" + json_InnerIndentation = "" + Exit Sub + End If + + Call json_BufferAppend(buffer, vbNewLine, bufferPosition, bufferLength) + + If VBA.VarType(whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(currentIndentation, whitespace) + Else + json_Indentation = VBA.Space$(currentIndentation * whitespace) + End If +End Sub + +'---------------------------------------------------------------------------------------- +'---------------------------------------------------------------------------------------- +'---------------------------------------------------------------------------------------- +'---------------------------------------------------------------------------------------- +'---------------------------------------------------------------------------------------- + '' ' VBA-UTC v1.0.6 ' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter @@ -950,7 +1090,7 @@ End Function '' Public Function ParseIso(utc_IsoString As String) As Date On Error GoTo utc_ErrorHandling - + Dim utc_Parts() As String Dim utc_DateParts() As String Dim utc_TimeParts() As String @@ -1038,7 +1178,7 @@ utc_ErrorHandling: End Function ' ============================================= ' -' Private Functions +' Private Functions - UTC ' ============================================= ' #If Mac Then