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...

Author: PGS62

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,15 +328,15 @@ 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
 
         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
+
+
+
+
+
+