From a31a3dd8002a22fa46332d23f8183d67a51c0be4 Mon Sep 17 00:00:00 2001 From: Trung-Hieu Nguyen Date: Sun, 22 Dec 2024 03:32:07 +0700 Subject: [PATCH 1/2] Refactoring ConvertToJson. - Adding module level variables: json_Indentation As String , json_InnerIndentation As String and json_PrettyPrint As Boolean - Adding sub modules: * json_IsArray2D, json_ConvertArray, json_Convert1DArray, json_Convert2DArray, json_ConvertObject, json_ConvertDictionary, json_ConvertCollection * json_PrettyPrint_PreConvert, json_PrettyPrint_PostConvert --- JsonConverter.bas | 622 ++++++++++++++++++++++++++++------------------ 1 file changed, 378 insertions(+), 244 deletions(-) diff --git a/JsonConverter.bas b/JsonConverter.bas index 876b865..1493ae6 100644 --- a/JsonConverter.bas +++ b/JsonConverter.bas @@ -155,6 +155,11 @@ 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 ' ============================================= ' @@ -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 @@ -950,7 +748,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 @@ -1037,6 +835,342 @@ utc_ErrorHandling: Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description 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 + ' ============================================= ' ' Private Functions ' ============================================= ' From 2c2d2d2af43961edd68ba2410516d9ade54b445b Mon Sep 17 00:00:00 2001 From: Trung-Hieu Nguyen Date: Sun, 22 Dec 2024 13:16:43 +0700 Subject: [PATCH 2/2] Refactoring ConvertToJson. - Adding module level variables: json_Indentation As String , json_InnerIndentation As String and json_PrettyPrint As Boolean - Adding sub procedures: * json_IsArray2D, json_ConvertArray, json_Convert1DArray, json_Convert2DArray, json_ConvertObject, json_ConvertDictionary, json_ConvertCollection * json_PrettyPrint_PreConvert, json_PrettyPrint_PostConvert - Rearrange all procedures to seperate UTC and Json modules --- JsonConverter.bas | 366 +++++++++++++++++++++++----------------------- 1 file changed, 186 insertions(+), 180 deletions(-) diff --git a/JsonConverter.bas b/JsonConverter.bas index 1493ae6..2369c3e 100644 --- a/JsonConverter.bas +++ b/JsonConverter.bas @@ -163,7 +163,7 @@ Private json_PrettyPrint As Boolean Public JsonOptions As json_Options ' ============================================= ' -' Public Methods +' Public Methods - Json ' ============================================= ' '' @@ -657,184 +657,6 @@ Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_Buf End If End Function -'' -' VBA-UTC v1.0.6 -' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter -' -' UTC/ISO 8601 Converter for VBA -' -' Errors: -' 10011 - UTC parsing error -' 10012 - UTC conversion error -' 10013 - ISO 8601 parsing error -' 10014 - ISO 8601 conversion error -' -' @module UtcConverter -' @author tim.hall.engr@gmail.com -' @license MIT (http://www.opensource.org/licenses/mit-license.php) -'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' - -' (Declarations moved to top) - -' ============================================= ' -' Public Methods -' ============================================= ' - -'' -' Parse UTC date to local date -' -' @method ParseUtc -' @param {Date} UtcDate -' @return {Date} Local date -' @throws 10011 - UTC parsing error -'' -Public Function ParseUtc(utc_UtcDate As Date) As Date - On Error GoTo utc_ErrorHandling - -#If Mac Then - ParseUtc = utc_ConvertDate(utc_UtcDate) -#Else - Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION - Dim utc_LocalDate As utc_SYSTEMTIME - - utc_GetTimeZoneInformation utc_TimeZoneInfo - utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate - - ParseUtc = utc_SystemTimeToDate(utc_LocalDate) -#End If - - Exit Function - -utc_ErrorHandling: - Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description -End Function - -'' -' Convert local date to UTC date -' -' @method ConvertToUrc -' @param {Date} utc_LocalDate -' @return {Date} UTC date -' @throws 10012 - UTC conversion error -'' -Public Function ConvertToUtc(utc_LocalDate As Date) As Date - On Error GoTo utc_ErrorHandling - -#If Mac Then - ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True) -#Else - Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION - Dim utc_UtcDate As utc_SYSTEMTIME - - utc_GetTimeZoneInformation utc_TimeZoneInfo - utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate - - ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate) -#End If - - Exit Function - -utc_ErrorHandling: - Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description -End Function - -'' -' Parse ISO 8601 date string to local date -' -' @method ParseIso -' @param {Date} utc_IsoString -' @return {Date} Local date -' @throws 10013 - ISO 8601 parsing error -'' -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 - Dim utc_OffsetIndex As Long - Dim utc_HasOffset As Boolean - Dim utc_NegativeOffset As Boolean - Dim utc_OffsetParts() As String - Dim utc_Offset As Date - - utc_Parts = VBA.Split(utc_IsoString, "T") - utc_DateParts = VBA.Split(utc_Parts(0), "-") - ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2))) - - If UBound(utc_Parts) > 0 Then - If VBA.InStr(utc_Parts(1), "Z") Then - utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":") - Else - utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+") - If utc_OffsetIndex = 0 Then - utc_NegativeOffset = True - utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-") - End If - - If utc_OffsetIndex > 0 Then - utc_HasOffset = True - utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":") - utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":") - - Select Case UBound(utc_OffsetParts) - Case 0 - utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0) - Case 1 - utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0) - Case 2 - ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues - utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2)))) - End Select - - If utc_NegativeOffset Then: utc_Offset = -utc_Offset - Else - utc_TimeParts = VBA.Split(utc_Parts(1), ":") - End If - End If - - Select Case UBound(utc_TimeParts) - Case 0 - ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0) - Case 1 - ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0) - Case 2 - ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues - ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2)))) - End Select - - ParseIso = ParseUtc(ParseIso) - - If utc_HasOffset Then - ParseIso = ParseIso - utc_Offset - End If - End If - - Exit Function - -utc_ErrorHandling: - Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description -End Function - -'' -' Convert local date to ISO 8601 string -' -' @method ConvertToIso -' @param {Date} utc_LocalDate -' @return {Date} ISO 8601 string -' @throws 10014 - ISO 8601 conversion error -'' -Public Function ConvertToIso(utc_LocalDate As Date) As String - On Error GoTo utc_ErrorHandling - - ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z") - - Exit Function - -utc_ErrorHandling: - Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description -End Function - ' ============================================= ' ' Private Functions - ConvertJSON ' ============================================= ' @@ -1171,8 +993,192 @@ Private Sub json_PrettyPrint_PostConvert(ByVal whitespace As Variant, _ End If End Sub +'---------------------------------------------------------------------------------------- +'---------------------------------------------------------------------------------------- +'---------------------------------------------------------------------------------------- +'---------------------------------------------------------------------------------------- +'---------------------------------------------------------------------------------------- + +'' +' VBA-UTC v1.0.6 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter +' +' UTC/ISO 8601 Converter for VBA +' +' Errors: +' 10011 - UTC parsing error +' 10012 - UTC conversion error +' 10013 - ISO 8601 parsing error +' 10014 - ISO 8601 conversion error +' +' @module UtcConverter +' @author tim.hall.engr@gmail.com +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' + +' (Declarations moved to top) + +' ============================================= ' +' Public Methods +' ============================================= ' + +'' +' Parse UTC date to local date +' +' @method ParseUtc +' @param {Date} UtcDate +' @return {Date} Local date +' @throws 10011 - UTC parsing error +'' +Public Function ParseUtc(utc_UtcDate As Date) As Date + On Error GoTo utc_ErrorHandling + +#If Mac Then + ParseUtc = utc_ConvertDate(utc_UtcDate) +#Else + Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION + Dim utc_LocalDate As utc_SYSTEMTIME + + utc_GetTimeZoneInformation utc_TimeZoneInfo + utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate + + ParseUtc = utc_SystemTimeToDate(utc_LocalDate) +#End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description +End Function + +'' +' Convert local date to UTC date +' +' @method ConvertToUrc +' @param {Date} utc_LocalDate +' @return {Date} UTC date +' @throws 10012 - UTC conversion error +'' +Public Function ConvertToUtc(utc_LocalDate As Date) As Date + On Error GoTo utc_ErrorHandling + +#If Mac Then + ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True) +#Else + Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION + Dim utc_UtcDate As utc_SYSTEMTIME + + utc_GetTimeZoneInformation utc_TimeZoneInfo + utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate + + ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate) +#End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description +End Function + +'' +' Parse ISO 8601 date string to local date +' +' @method ParseIso +' @param {Date} utc_IsoString +' @return {Date} Local date +' @throws 10013 - ISO 8601 parsing error +'' +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 + Dim utc_OffsetIndex As Long + Dim utc_HasOffset As Boolean + Dim utc_NegativeOffset As Boolean + Dim utc_OffsetParts() As String + Dim utc_Offset As Date + + utc_Parts = VBA.Split(utc_IsoString, "T") + utc_DateParts = VBA.Split(utc_Parts(0), "-") + ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2))) + + If UBound(utc_Parts) > 0 Then + If VBA.InStr(utc_Parts(1), "Z") Then + utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":") + Else + utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+") + If utc_OffsetIndex = 0 Then + utc_NegativeOffset = True + utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-") + End If + + If utc_OffsetIndex > 0 Then + utc_HasOffset = True + utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":") + utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":") + + Select Case UBound(utc_OffsetParts) + Case 0 + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0) + Case 1 + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0) + Case 2 + ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2)))) + End Select + + If utc_NegativeOffset Then: utc_Offset = -utc_Offset + Else + utc_TimeParts = VBA.Split(utc_Parts(1), ":") + End If + End If + + Select Case UBound(utc_TimeParts) + Case 0 + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0) + Case 1 + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0) + Case 2 + ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2)))) + End Select + + ParseIso = ParseUtc(ParseIso) + + If utc_HasOffset Then + ParseIso = ParseIso - utc_Offset + End If + End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description +End Function + +'' +' Convert local date to ISO 8601 string +' +' @method ConvertToIso +' @param {Date} utc_LocalDate +' @return {Date} ISO 8601 string +' @throws 10014 - ISO 8601 conversion error +'' +Public Function ConvertToIso(utc_LocalDate As Date) As String + On Error GoTo utc_ErrorHandling + + ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z") + + Exit Function + +utc_ErrorHandling: + Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description +End Function + ' ============================================= ' -' Private Functions +' Private Functions - UTC ' ============================================= ' #If Mac Then