From 17ceebe9e5115b34b8f94b7261962262759d3c98 Mon Sep 17 00:00:00 2001 From: philip_swannell Date: Fri, 26 Jan 2018 18:13:08 +0000 Subject: [PATCH 1/5] 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 f3476b2..8239de7 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.5 @@ -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 From d79a44ae693ffecc92adf28cd4d8565d429cdeb5 Mon Sep 17 00:00:00 2001 From: Tim Hall Date: Thu, 7 Jun 2018 08:42:59 -0400 Subject: [PATCH 2/5] Remove test modules --- modTest1.bas | 182 --------------------------------------------------- modTest2.bas | 27 -------- 2 files changed, 209 deletions(-) delete mode 100644 modTest1.bas delete mode 100644 modTest2.bas diff --git a/modTest1.bas b/modTest1.bas deleted file mode 100644 index e292079..0000000 --- a/modTest1.bas +++ /dev/null @@ -1,182 +0,0 @@ -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 deleted file mode 100644 index cfb7912..0000000 --- a/modTest2.bas +++ /dev/null @@ -1,27 +0,0 @@ -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 From cf4e1649884851f5707b52649e09230daf17c33b Mon Sep 17 00:00:00 2001 From: Tim Hall Date: Thu, 7 Jun 2018 09:06:44 -0400 Subject: [PATCH 3/5] Inline clsStringAppend --- JsonConverter.bas | 139 ++++++++++++++++++++++++++++++-------------- clsStringAppend.cls | 56 ------------------ 2 files changed, 95 insertions(+), 100 deletions(-) delete mode 100644 clsStringAppend.cls diff --git a/JsonConverter.bas b/JsonConverter.bas index 8239de7..3fedadb 100644 --- a/JsonConverter.bas +++ b/JsonConverter.bas @@ -140,7 +140,6 @@ End Type #End If ' === End VBA-UTC - Private Type json_Options ' VBA only stores 15 significant digits, so any numbers larger than that are truncated ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits @@ -198,7 +197,9 @@ 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 cSA As New clsStringAppend + 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 @@ -257,7 +258,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp End If ' Array - cSA.Append "[" + json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength On Error Resume Next @@ -272,21 +273,21 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp json_IsFirstItem = False Else ' Append comma to previous line - cSA.Append "," + 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 - cSA.Append vbNewLine + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength End If - cSA.Append json_Indentation & "[" + 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 - cSA.Append "," + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength End If json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) @@ -303,14 +304,14 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp json_Converted = vbNewLine & json_InnerIndentation & json_Converted End If - cSA.Append json_Converted + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength Next json_Index2D If json_PrettyPrint Then - cSA.Append vbNewLine + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength End If - cSA.Append json_Indentation & "]" + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength json_IsFirstItem2D = True Else ' 1D Array @@ -328,7 +329,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp json_Converted = vbNewLine & json_Indentation & json_Converted End If - cSA.Append json_Converted + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength End If Next json_Index End If @@ -336,7 +337,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp On Error GoTo 0 If json_PrettyPrint Then - cSA.Append vbNewLine + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength If VBA.VarType(Whitespace) = VBA.vbString Then json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) @@ -345,9 +346,9 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp End If End If - cSA.Append json_Indentation & "]" + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength - ConvertToJson = cSA.Report + ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition, json_BufferLength) ' Dictionary or Collection Case VBA.vbObject @@ -361,7 +362,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp ' Dictionary If VBA.TypeName(JsonValue) = "Dictionary" Then - cSA.Append "{" + 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) @@ -375,7 +376,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp If json_IsFirstItem Then json_IsFirstItem = False Else - cSA.Append "," + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength End If If json_PrettyPrint Then @@ -384,12 +385,12 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp json_Converted = """" & json_Key & """:" & json_Converted End If - cSA.Append json_Converted + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength End If Next json_Key If json_PrettyPrint Then - cSA.Append vbNewLine + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength If VBA.VarType(Whitespace) = VBA.vbString Then json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) @@ -398,16 +399,16 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp End If End If - cSA.Append json_Indentation & "}" + json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength ' Collection ElseIf VBA.TypeName(JsonValue) = "Collection" Then - cSA.Append "[" + json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength For Each json_Value In JsonValue If json_IsFirstItem Then json_IsFirstItem = False Else - cSA.Append "," + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength End If json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) @@ -424,11 +425,11 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp json_Converted = vbNewLine & json_Indentation & json_Converted End If - cSA.Append json_Converted + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength Next json_Value If json_PrettyPrint Then - cSA.Append vbNewLine + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength If VBA.VarType(Whitespace) = VBA.vbString Then json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) @@ -437,10 +438,10 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp End If End If - cSA.Append json_Indentation & "]" + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength End If - ConvertToJson = cSA.Report + ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition, json_BufferLength) Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal ' Number (use decimals for numbers) ConvertToJson = VBA.Replace(JsonValue, ",", ".") @@ -544,7 +545,9 @@ 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 cSA As New clsStringAppend + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long json_SkipSpaces json_String, json_Index @@ -563,36 +566,36 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon Select Case json_Char Case """", "\", "/", "'" - cSA.Append json_Char + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 Case "b" - cSA.Append vbBack + json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 Case "f" - cSA.Append vbFormFeed + json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 Case "n" - cSA.Append vbCrLf + json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 Case "r" - cSA.Append vbCr + json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 Case "t" - cSA.Append vbTab + json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength 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) - cSA.Append VBA.ChrW(VBA.Val("&h" + json_Code)) + json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength json_Index = json_Index + 4 End Select Case json_Quote - json_ParseString = cSA.Report + json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition, json_BufferLength) json_Index = json_Index + 1 Exit Function Case Else - cSA.Append json_Char + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 End Select Loop @@ -678,7 +681,9 @@ 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 cSA As New clsStringAppend + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long For json_Index = 1 To VBA.Len(json_Text) json_Char = VBA.Mid$(json_Text, json_Index, 1) @@ -725,10 +730,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 - cSA.Append json_Char + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength Next json_Index - json_Encode = cSA.Report + json_Encode = json_BufferToString(json_Buffer, json_BufferPosition, json_BufferLength) End Function Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String @@ -801,7 +806,59 @@ 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) + ' 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 + ' + ' Put "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 + ' + ' and clsStringAppend from Philip Swannell + ' https://github.com/VBA-tools/VBA-JSON/pull/82 + + Dim json_AppendLength As Long + Dim json_LengthPlusPosition As Long + + json_AppendLength = VBA.Len(json_Append) + json_LengthPlusPosition = json_AppendLength + json_BufferPosition + + If json_LengthPlusPosition > json_BufferLength Then + ' Appending would overflow buffer, add chunk + ' (double buffer length or append length, whichever is bigger) + Dim json_AddedLength As Long + json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength) + + json_Buffer = json_Buffer & VBA.Space$(json_AddedLength) + json_BufferLength = json_BufferLength + json_AddedLength + End If + + ' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error: + ' Function call on left-hand side of assignment must return Variant or Object + Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append) + json_BufferPosition = json_BufferPosition + json_AppendLength +End Sub +Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long, ByVal json_BufferLength As Long) As String + If json_BufferPosition > 0 Then + json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition) + End If +End Function '' ' VBA-UTC v1.0.5 @@ -1065,9 +1122,3 @@ Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date End Function #End If - - - - - - diff --git a/clsStringAppend.cls b/clsStringAppend.cls deleted file mode 100644 index 7fd51db..0000000 --- a/clsStringAppend.cls +++ /dev/null @@ -1,56 +0,0 @@ -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 From bc913ff27c645f8866230eb0dcbda1f6af8d3893 Mon Sep 17 00:00:00 2001 From: Tim Hall Date: Thu, 7 Jun 2018 09:12:48 -0400 Subject: [PATCH 4/5] Cleanup --- JsonConverter.bas | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/JsonConverter.bas b/JsonConverter.bas index 3fedadb..34e99af 100644 --- a/JsonConverter.bas +++ b/JsonConverter.bas @@ -348,7 +348,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength - ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition, json_BufferLength) + ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) ' Dictionary or Collection Case VBA.vbObject @@ -441,7 +441,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength End If - ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition, json_BufferLength) + 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, ",", ".") @@ -591,7 +591,7 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon json_Index = json_Index + 4 End Select Case json_Quote - json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition, json_BufferLength) + json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition) json_Index = json_Index + 1 Exit Function Case Else @@ -733,7 +733,7 @@ Private Function json_Encode(ByVal json_Text As Variant) As String json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength Next json_Index - json_Encode = json_BufferToString(json_Buffer, json_BufferPosition, json_BufferLength) + json_Encode = json_BufferToString(json_Buffer, json_BufferPosition) End Function Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String @@ -760,7 +760,6 @@ Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean ' Length with be at least 16 characters and assume will be less than 100 characters If json_Length >= 16 And json_Length <= 100 Then Dim json_CharCode As String - Dim json_Index As Long json_StringIsLargeNumber = True @@ -854,7 +853,7 @@ Private Sub json_BufferAppend(ByRef json_Buffer As String, _ json_BufferPosition = json_BufferPosition + json_AppendLength End Sub -Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long, ByVal json_BufferLength As Long) As String +Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String If json_BufferPosition > 0 Then json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition) End If From 45aff20539aa3be973f06a9046000d96ca4a004a Mon Sep 17 00:00:00 2001 From: Tim Hall Date: Thu, 7 Jun 2018 10:48:39 -0400 Subject: [PATCH 5/5] Fix failing test on Mac --- specs/Specs.bas | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/specs/Specs.bas b/specs/Specs.bas index 6f0a28d..893f878 100644 --- a/specs/Specs.bas +++ b/specs/Specs.bas @@ -258,7 +258,7 @@ Public Function Specs() As SpecSuite With Specs.It("should json-encode strings") Dim Strings As Variant - Strings = Array("""\" & vbCrLf & vbTab & vbBack & vbFormFeed, ChrW(128) & ChrW(32767), "#$%&{|}~") + Strings = Array("""\" & vbCr & vbLf & vbTab & vbBack & vbFormFeed, ChrW(128) & ChrW(32767), "#$%&{|}~") JsonString = JsonConverter.ConvertToJson(Strings) .Expect(JsonString).ToEqual "[""\""\\\r\n\t\b\f"",""\u0080\u7FFF"",""#$%&{|}~""]"