From 0a88ffd8fd4a73ba58ba6b95cd463271062d0180 Mon Sep 17 00:00:00 2001 From: philip_swannell Date: Fri, 26 Jan 2018 18:13:08 +0000 Subject: [PATCH] json_BufferAppend replaced with clsStringAppend Replaced calls to json_BufferAppend with simple class module clsStringAppend. Code is faster (x5), simpler and should work on Mac as well as Windows, though I have not tested that... --- JsonConverter.bas | 184 +++++++++++--------------------------------- clsStringAppend.cls | 56 ++++++++++++++ modTest1.bas | 182 +++++++++++++++++++++++++++++++++++++++++++ modTest2.bas | 27 +++++++ 4 files changed, 308 insertions(+), 141 deletions(-) create mode 100644 clsStringAppend.cls create mode 100644 modTest1.bas create mode 100644 modTest2.bas diff --git a/JsonConverter.bas b/JsonConverter.bas index 1e847f4..56093c4 100644 --- a/JsonConverter.bas +++ b/JsonConverter.bas @@ -140,18 +140,6 @@ End Type #End If ' === End VBA-UTC -#If Mac Then -#ElseIf VBA7 Then - -Private Declare PtrSafe Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ - (json_MemoryDestination As Any, json_MemorySource As Any, ByVal json_ByteLength As Long) - -#Else - -Private Declare Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ - (json_MemoryDestination As Any, json_MemorySource As Any, ByVal json_ByteLength As Long) - -#End If Private Type json_Options ' VBA only stores 15 significant digits, so any numbers larger than that are truncated @@ -210,9 +198,7 @@ End Function ' @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 cSA As New clsStringAppend Dim json_Index As Long Dim json_LBound As Long Dim json_UBound As Long @@ -271,7 +257,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp End If ' Array - json_BufferAppend json_buffer, "[", json_BufferPosition, json_BufferLength + cSA.Append "[" On Error Resume Next @@ -286,21 +272,21 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp json_IsFirstItem = False Else ' Append comma to previous line - json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength + cSA.Append "," 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 + cSA.Append vbNewLine End If - json_BufferAppend json_buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength + cSA.Append json_Indentation & "[" For json_Index2D = json_LBound2D To json_UBound2D If json_IsFirstItem2D Then json_IsFirstItem2D = False Else - json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength + cSA.Append "," End If json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) @@ -317,14 +303,14 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp json_Converted = vbNewLine & json_InnerIndentation & json_Converted End If - json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength + cSA.Append json_Converted Next json_Index2D If json_PrettyPrint Then - json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength + cSA.Append vbNewLine End If - json_BufferAppend json_buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + cSA.Append json_Indentation & "]" json_IsFirstItem2D = True Else ' 1D Array @@ -342,7 +328,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp json_Converted = vbNewLine & json_Indentation & json_Converted End If - json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength + cSA.Append json_Converted End If Next json_Index End If @@ -350,7 +336,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp On Error GoTo 0 If json_PrettyPrint Then - json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength + cSA.Append vbNewLine If VBA.VarType(Whitespace) = VBA.vbString Then json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) @@ -359,9 +345,9 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp End If End If - json_BufferAppend json_buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + cSA.Append json_Indentation & "]" - ConvertToJson = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength) + ConvertToJson = cSA.Report ' Dictionary or Collection Case VBA.vbObject @@ -375,7 +361,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp ' Dictionary If VBA.TypeName(JsonValue) = "Dictionary" Then - json_BufferAppend json_buffer, "{", json_BufferPosition, json_BufferLength + cSA.Append "{" 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) @@ -389,7 +375,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp If json_IsFirstItem Then json_IsFirstItem = False Else - json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength + cSA.Append "," End If If json_PrettyPrint Then @@ -398,12 +384,12 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp json_Converted = """" & json_Key & """:" & json_Converted End If - json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength + cSA.Append json_Converted End If Next json_Key If json_PrettyPrint Then - json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength + cSA.Append vbNewLine If VBA.VarType(Whitespace) = VBA.vbString Then json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) @@ -412,16 +398,16 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp End If End If - json_BufferAppend json_buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength + cSA.Append json_Indentation & "}" ' Collection ElseIf VBA.TypeName(JsonValue) = "Collection" Then - json_BufferAppend json_buffer, "[", json_BufferPosition, json_BufferLength + cSA.Append "[" For Each json_Value In JsonValue If json_IsFirstItem Then json_IsFirstItem = False Else - json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength + cSA.Append "," End If json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) @@ -438,11 +424,11 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp json_Converted = vbNewLine & json_Indentation & json_Converted End If - json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength + cSA.Append json_Converted Next json_Value If json_PrettyPrint Then - json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength + cSA.Append vbNewLine If VBA.VarType(Whitespace) = VBA.vbString Then json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) @@ -451,10 +437,10 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp End If End If - json_BufferAppend json_buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + cSA.Append json_Indentation & "]" End If - ConvertToJson = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength) + ConvertToJson = cSA.Report Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal ' Number (use decimals for numbers) ConvertToJson = VBA.Replace(JsonValue, ",", ".") @@ -558,9 +544,7 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon Dim json_Quote As String Dim json_Char As String Dim json_Code As String - Dim json_buffer As String - Dim json_BufferPosition As Long - Dim json_BufferLength As Long + Dim cSA As New clsStringAppend json_SkipSpaces json_String, json_Index @@ -579,36 +563,36 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon Select Case json_Char Case """", "\", "/", "'" - json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength + cSA.Append json_Char json_Index = json_Index + 1 Case "b" - json_BufferAppend json_buffer, vbBack, json_BufferPosition, json_BufferLength + cSA.Append vbBack json_Index = json_Index + 1 Case "f" - json_BufferAppend json_buffer, vbFormFeed, json_BufferPosition, json_BufferLength + cSA.Append vbFormFeed json_Index = json_Index + 1 Case "n" - json_BufferAppend json_buffer, vbCrLf, json_BufferPosition, json_BufferLength + cSA.Append vbCrLf json_Index = json_Index + 1 Case "r" - json_BufferAppend json_buffer, vbCr, json_BufferPosition, json_BufferLength + cSA.Append vbCr json_Index = json_Index + 1 Case "t" - json_BufferAppend json_buffer, vbTab, json_BufferPosition, json_BufferLength + cSA.Append vbTab json_Index = json_Index + 1 Case "u" ' Unicode character escape (e.g. \u00a9 = Copyright) json_Index = json_Index + 1 json_Code = VBA.Mid$(json_String, json_Index, 4) - json_BufferAppend json_buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength + cSA.Append VBA.ChrW(VBA.Val("&h" + json_Code)) json_Index = json_Index + 4 End Select Case json_Quote - json_ParseString = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength) + json_ParseString = cSA.Report json_Index = json_Index + 1 Exit Function Case Else - json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength + cSA.Append json_Char json_Index = json_Index + 1 End Select Loop @@ -694,9 +678,7 @@ Private Function json_Encode(ByVal json_Text As Variant) As String Dim json_Index As Long Dim json_Char As String Dim json_AscCode As Long - Dim json_buffer As String - Dim json_BufferPosition As Long - Dim json_BufferLength As Long + Dim cSA As New clsStringAppend For json_Index = 1 To VBA.Len(json_Text) json_Char = VBA.Mid$(json_Text, json_Index, 1) @@ -743,10 +725,10 @@ Private Function json_Encode(ByVal json_Text As Variant) As String json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4) End Select - json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength + cSA.Append json_Char Next json_Index - json_Encode = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength) + json_Encode = cSA.Report End Function Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String @@ -819,93 +801,7 @@ Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index ErrorMessage End Function -Private Sub json_BufferAppend(ByRef json_buffer As String, _ - ByRef json_Append As Variant, _ - ByRef json_BufferPosition As Long, _ - ByRef json_BufferLength As Long) -#If Mac Then - json_buffer = json_buffer & json_Append -#Else - ' VBA can be slow to append strings due to allocating a new string for each append - ' Instead of using the traditional append, allocate a large empty string and then copy string at append position - ' - ' Example: - ' Buffer: "abc " - ' Append: "def" - ' Buffer Position: 3 - ' Buffer Length: 5 - ' - ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer - ' Buffer: "abc " - ' Buffer Length: 10 - ' - ' Copy memory for "def" into buffer at position 3 (0-based) - ' Buffer: "abcdef " - ' - ' Approach based on cStringBuilder from vbAccelerator - ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp - - Dim json_AppendLength As Long - Dim json_LengthPlusPosition As Long - - json_AppendLength = VBA.LenB(json_Append) - json_LengthPlusPosition = json_AppendLength + json_BufferPosition - - If json_LengthPlusPosition > json_BufferLength Then - ' Appending would overflow buffer, add chunks until buffer is long enough - Dim json_TemporaryLength As Long - - json_TemporaryLength = json_BufferLength - Do While json_TemporaryLength < json_LengthPlusPosition - ' Initially, initialize string with 255 characters, - ' then add large chunks (8192) after that - ' - ' Size: # Characters x 2 bytes / character - If json_TemporaryLength = 0 Then - json_TemporaryLength = json_TemporaryLength + 510 - Else - json_TemporaryLength = json_TemporaryLength + 16384 - End If - Loop - - json_buffer = json_buffer & VBA.Space$((json_TemporaryLength - json_BufferLength) \ 2) - json_BufferLength = json_TemporaryLength - End If - - ' Copy memory from append to buffer at buffer position - json_CopyMemory ByVal json_UnsignedAdd(StrPtr(json_buffer), _ - json_BufferPosition), _ - ByVal StrPtr(json_Append), _ - json_AppendLength - - json_BufferPosition = json_BufferPosition + json_AppendLength -#End If -End Sub - -Private Function json_BufferToString(ByRef json_buffer As String, ByVal json_BufferPosition As Long, ByVal json_BufferLength As Long) As String -#If Mac Then - json_BufferToString = json_buffer -#Else - If json_BufferPosition > 0 Then - json_BufferToString = VBA.Left$(json_buffer, json_BufferPosition \ 2) - End If -#End If -End Function - -#If VBA7 Then -Private Function json_UnsignedAdd(json_Start As LongPtr, json_Increment As Long) As LongPtr -#Else -Private Function json_UnsignedAdd(json_Start As Long, json_Increment As Long) As Long -#End If - If json_Start And &H80000000 Then - json_UnsignedAdd = json_Start + json_Increment - ElseIf (json_Start Or &H80000000) < -json_Increment Then - json_UnsignedAdd = json_Start + json_Increment - Else - json_UnsignedAdd = (json_Start + &H80000000) + (json_Increment + &H80000000) - End If -End Function '' ' VBA-UTC v1.0.3 @@ -1169,3 +1065,9 @@ Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date End Function #End If + + + + + + diff --git a/clsStringAppend.cls b/clsStringAppend.cls new file mode 100644 index 0000000..7fd51db --- /dev/null +++ b/clsStringAppend.cls @@ -0,0 +1,56 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "clsStringAppend" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = True +Option Explicit +'--------------------------------------------------------------------------------------- +' Module : clsStringAppend +' Author : Philip Swannell +' Date : 26-Jan-2018 +' Purpose : Class for constructing strings in a loop, avoiding "Shlemiel the painter" performance +'--------------------------------------------------------------------------------------- +Option Base 1 +Dim m_TheString As String +Dim m_NumCharsWritten As Long +Dim m_NumCharsStored As Long + +Public Function Report() +1 On Error GoTo ErrHandler +2 Report = VBA.Left$(m_TheString, m_NumCharsWritten) +3 Exit Function +ErrHandler: +4 Err.Raise vbObjectError + 1, , "#clsStringAppend.Report (line " & CStr(Erl) + "): " & Err.Description & "!" +End Function + +Private Function Max(x As Long, y As Long) +1 If x > y Then +2 Max = x +3 Else +4 Max = y +5 End If +End Function + +Public Sub Append(TheString As String) + Dim L As Long + Dim NumCharsToAdd As Long +1 On Error GoTo ErrHandler +2 L = VBA.Len(TheString) + +3 If L + m_NumCharsWritten > m_NumCharsStored Then +4 NumCharsToAdd = Max(L, m_NumCharsStored) +5 m_TheString = m_TheString + VBA.Space$(NumCharsToAdd) +6 m_NumCharsStored = m_NumCharsStored + NumCharsToAdd +7 End If + +8 Mid$(m_TheString, m_NumCharsWritten + 1, L) = TheString +9 m_NumCharsWritten = m_NumCharsWritten + L + +10 Exit Sub +ErrHandler: +11 Err.Raise vbObjectError + 1, , "#clsStringAppend.Append (line " & CStr(Erl) + "): " & Err.Description & "!" +End Sub diff --git a/modTest1.bas b/modTest1.bas new file mode 100644 index 0000000..e292079 --- /dev/null +++ b/modTest1.bas @@ -0,0 +1,182 @@ +Attribute VB_Name = "modTest1" +Option Explicit + +Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long +Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long + +#If Mac Then +#ElseIf VBA7 Then + +Private Declare PtrSafe Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ + (json_MemoryDestination As Any, json_MemorySource As Any, ByVal json_ByteLength As Long) + +#Else + +Private Declare Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ + (json_MemoryDestination As Any, json_MemorySource As Any, ByVal json_ByteLength As Long) + +#End If + +'--------------------------------------------------------------------------------------- +' Procedure : sElapsedTime +' Author : Philip Swannell +' Date : 16-Jun-2013 +' Purpose : Returns time in seconds since system start up. High resolution. +' See http://msdn.microsoft.com/en-us/library/windows/desktop/ms644904(v=vs.85).aspx +'--------------------------------------------------------------------------------------- +Function sElapsedTime() As Double + Dim a As Currency, b As Currency +1 On Error GoTo ErrHandler + +2 QueryPerformanceCounter a +3 QueryPerformanceFrequency b +4 sElapsedTime = a / b +5 Exit Function +ErrHandler: +6 Err.Raise vbObjectError + 1, , "#sElapsedTime (line " & CStr(Erl) + "): " & Err.Description & "!" +End Function + +' ----------------------------------------------------------------------------------------------------------------------- +' Procedure : CompareTwoMethods +' Author : Philip Swannell +' Date : 26-Jan-2018 +' Purpose : Test harness to compare execution speed of existing json_BufferAppend versus clsStringAppend +' For N from 1000 to 1000000 I get clsAppend approx 5 times faster than json_BufferAppend +' In addition, clsAppend does not use Windows API calls and thus should work on Mac. I presume (but +' haven't tested) that the code as is exhibits ""Shlemiel the painter" performance on Mac since +' method json_BufferAppend just does naive string append on Mac. +' ----------------------------------------------------------------------------------------------------------------------- +Sub CompareTwoMethods() + Dim Result1 As String, Result2 As String + Dim AppendThis As String + Dim i As Long, N As Long + Dim t1 As Double, t2 As Double, t3 As Double + Dim json_buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + Dim cSA As New clsStringAppend + +1 On Error GoTo ErrHandler +2 AppendThis = "xyz" +3 N = 100000 + +4 t1 = sElapsedTime() + +5 For i = 1 To N +6 json_BufferAppend json_buffer, AppendThis, json_BufferPosition, json_BufferLength +7 Next i +8 Result1 = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength) + +9 t2 = sElapsedTime() + +10 For i = 1 To N +11 cSA.Append AppendThis +12 Next i +13 Result2 = cSA.Report + +14 t3 = sElapsedTime() + +15 Debug.Print String(50, "-") +16 Debug.Print "N = " & Format(N, "###,###") & " Len(AppendThis) = " & Len(AppendThis) +17 Debug.Print "Results Agree?", Result1 = Result2 +18 Debug.Print "Time json_BufferToString", Format((t2 - t1) * 1000, "0.000") & " milliseconds" +19 Debug.Print "Time clsStringAppend", Format((t3 - t2) * 1000, "0.000") & " milliseconds" +20 Debug.Print "Ratio: ", (t2 - t1) / (t3 - t2) + + +21 Exit Sub +ErrHandler: +22 MsgBox "#CompareTwoMethods (line " & CStr(Erl) + "): " & Err.Description & "!", vbCritical +End Sub + +Private Sub json_BufferAppend(ByRef json_buffer As String, _ + ByRef json_Append As Variant, _ + ByRef json_BufferPosition As Long, _ + ByRef json_BufferLength As Long) +#If Mac Then + json_buffer = json_buffer & json_Append +#Else + ' VBA can be slow to append strings due to allocating a new string for each append + ' Instead of using the traditional append, allocate a large empty string and then copy string at append position + ' + ' Example: + ' Buffer: "abc " + ' Append: "def" + ' Buffer Position: 3 + ' Buffer Length: 5 + ' + ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer + ' Buffer: "abc " + ' Buffer Length: 10 + ' + ' Copy memory for "def" into buffer at position 3 (0-based) + ' Buffer: "abcdef " + ' + ' Approach based on cStringBuilder from vbAccelerator + ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp + + Dim json_AppendLength As Long + Dim json_LengthPlusPosition As Long + + json_AppendLength = VBA.LenB(json_Append) + json_LengthPlusPosition = json_AppendLength + json_BufferPosition + + If json_LengthPlusPosition > json_BufferLength Then + ' Appending would overflow buffer, add chunks until buffer is long enough + Dim json_TemporaryLength As Long + + json_TemporaryLength = json_BufferLength + Do While json_TemporaryLength < json_LengthPlusPosition + ' Initially, initialize string with 255 characters, + ' then add large chunks (8192) after that + ' + ' Size: # Characters x 2 bytes / character + If json_TemporaryLength = 0 Then + json_TemporaryLength = json_TemporaryLength + 510 + Else + json_TemporaryLength = json_TemporaryLength + 16384 + End If + Loop + + json_buffer = json_buffer & VBA.Space$((json_TemporaryLength - json_BufferLength) \ 2) + json_BufferLength = json_TemporaryLength + End If + + ' Copy memory from append to buffer at buffer position + json_CopyMemory ByVal json_UnsignedAdd(StrPtr(json_buffer), _ + json_BufferPosition), _ + ByVal StrPtr(json_Append), _ + json_AppendLength + + json_BufferPosition = json_BufferPosition + json_AppendLength +#End If +End Sub + +Private Function json_BufferToString(ByRef json_buffer As String, ByVal json_BufferPosition As Long, ByVal json_BufferLength As Long) As String +#If Mac Then + json_BufferToString = json_buffer +#Else + If json_BufferPosition > 0 Then + json_BufferToString = VBA.Left$(json_buffer, json_BufferPosition \ 2) + End If +#End If +End Function + +#If VBA7 Then +Private Function json_UnsignedAdd(json_Start As LongPtr, json_Increment As Long) As LongPtr +#Else +Private Function json_UnsignedAdd(json_Start As Long, json_Increment As Long) As Long +#End If + + If json_Start And &H80000000 Then + json_UnsignedAdd = json_Start + json_Increment + ElseIf (json_Start Or &H80000000) < -json_Increment Then + json_UnsignedAdd = json_Start + json_Increment + Else + json_UnsignedAdd = (json_Start + &H80000000) + (json_Increment + &H80000000) + End If +End Function + + + + diff --git a/modTest2.bas b/modTest2.bas new file mode 100644 index 0000000..cfb7912 --- /dev/null +++ b/modTest2.bas @@ -0,0 +1,27 @@ +Attribute VB_Name = "modTest2" +Option Explicit + +' ----------------------------------------------------------------------------------------------------------------------- +' Procedure : TestRoundTrip +' Author : Philip Swannell +' Date : 26-Jan-2018 +' Purpose : For a super simple example check that Dictionary > JSON String > Dictionary gets back to where we started... +' ----------------------------------------------------------------------------------------------------------------------- +Sub TestRoundTrip() + + Dim DCTIn As New Dictionary + Dim DCTOut As Dictionary + Dim JsonString As String + Dim JsonString2 As String + + DCTIn.Add "Number", 100 + DCTIn.Add "String", "Hello" + DCTIn.Add "Array", Array(1, 2, 3, 4, 5) + JsonString = ConvertToJson(DCTIn) + + Set DCTOut = ParseJson(JsonString) + JsonString2 = ConvertToJson(DCTOut) + + Debug.Print JsonString = JsonString2 + +End Sub