Skip to content

Commit 32cdbc7

Browse files
timhalltimhall
committed
Inline clsStringAppend
1 parent 717e79e commit 32cdbc7

File tree

2 files changed

+102
-107
lines changed

2 files changed

+102
-107
lines changed

‎JsonConverter.bas

Lines changed: 102 additions & 51 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
Attribute VB_Name = "JsonConverter"
22
''
3-
' VBA-JSON v2.2.3
3+
' VBA-JSON v2.2.4
44
' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON
55
'
66
' JSON Converter for VBA
@@ -54,7 +54,7 @@ Option Explicit
5454
Private Declare PtrSafe Function utc_popen Lib "libc.dylib" Alias "popen" _
5555
(ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr
5656
Private Declare PtrSafe Function utc_pclose Lib "libc.dylib" Alias "pclose" _
57-
(ByVal utc_File As Long) As LongPtr
57+
(ByVal utc_File As LongPtr) As LongPtr
5858
Private Declare PtrSafe Function utc_fread Lib "libc.dylib" Alias "fread" _
5959
(ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr
6060
Private Declare PtrSafe Function utc_feof Lib "libc.dylib" Alias "feof" _
@@ -140,7 +140,6 @@ End Type
140140
#End If
141141
' === End VBA-UTC
142142

143-
144143
Private Type json_Options
145144
' VBA only stores 15 significant digits, so any numbers larger than that are truncated
146145
' 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
198197
' @return {String}
199198
''
200199
Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String
201-
Dim cSA As New clsStringAppend
200+
Dim json_Buffer As String
201+
Dim json_BufferPosition As Long
202+
Dim json_BufferLength As Long
202203
Dim json_Index As Long
203204
Dim json_LBound As Long
204205
Dim json_UBound As Long
@@ -257,7 +258,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
257258
End If
258259

259260
' Array
260-
cSA.Append "["
261+
json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength
261262

262263
On Error Resume Next
263264

@@ -272,21 +273,21 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
272273
json_IsFirstItem = False
273274
Else
274275
' Append comma to previous line
275-
cSA.Append ","
276+
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
276277
End If
277278

278279
If json_LBound2D >= 0 And json_UBound2D >= 0 Then
279280
' 2D Array
280281
If json_PrettyPrint Then
281-
cSA.Append vbNewLine
282+
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
282283
End If
283-
cSA.Append json_Indentation & "["
284+
json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength
284285

285286
For json_Index2D = json_LBound2D To json_UBound2D
286287
If json_IsFirstItem2D Then
287288
json_IsFirstItem2D = False
288289
Else
289-
cSA.Append ","
290+
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
290291
End If
291292

292293
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
303304
json_Converted = vbNewLine & json_InnerIndentation & json_Converted
304305
End If
305306

306-
cSA.Append json_Converted
307+
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
307308
Next json_Index2D
308309

309310
If json_PrettyPrint Then
310-
cSA.Append vbNewLine
311+
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
311312
End If
312313

313-
cSA.Append json_Indentation & "]"
314+
json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
314315
json_IsFirstItem2D = True
315316
Else
316317
' 1D Array
@@ -328,15 +329,15 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
328329
json_Converted = vbNewLine & json_Indentation & json_Converted
329330
End If
330331

331-
cSA.Append json_Converted
332+
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
332333
End If
333334
Next json_Index
334335
End If
335336

336337
On Error GoTo 0
337338

338339
If json_PrettyPrint Then
339-
cSA.Append vbNewLine
340+
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
340341

341342
If VBA.VarType(Whitespace) = VBA.vbString Then
342343
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
@@ -345,9 +346,9 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
345346
End If
346347
End If
347348

348-
cSA.Append json_Indentation & "]"
349+
json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
349350

350-
ConvertToJson = cSA.Report
351+
ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition, json_BufferLength)
351352

352353
' Dictionary or Collection
353354
Case VBA.vbObject
@@ -361,7 +362,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
361362

362363
' Dictionary
363364
If VBA.TypeName(JsonValue) = "Dictionary" Then
364-
cSA.Append "{"
365+
json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength
365366
For Each json_Key In JsonValue.Keys
366367
' For Objects, undefined (Empty/Nothing) is not added to object
367368
json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1)
@@ -375,7 +376,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
375376
If json_IsFirstItem Then
376377
json_IsFirstItem = False
377378
Else
378-
cSA.Append ","
379+
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
379380
End If
380381

381382
If json_PrettyPrint Then
@@ -384,12 +385,12 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
384385
json_Converted = """" & json_Key & """:" & json_Converted
385386
End If
386387

387-
cSA.Append json_Converted
388+
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
388389
End If
389390
Next json_Key
390391

391392
If json_PrettyPrint Then
392-
cSA.Append vbNewLine
393+
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
393394

394395
If VBA.VarType(Whitespace) = VBA.vbString Then
395396
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
@@ -398,16 +399,16 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
398399
End If
399400
End If
400401

401-
cSA.Append json_Indentation & "}"
402+
json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength
402403

403404
' Collection
404405
ElseIf VBA.TypeName(JsonValue) = "Collection" Then
405-
cSA.Append "["
406+
json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength
406407
For Each json_Value In JsonValue
407408
If json_IsFirstItem Then
408409
json_IsFirstItem = False
409410
Else
410-
cSA.Append ","
411+
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
411412
End If
412413

413414
json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1)
@@ -424,11 +425,11 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
424425
json_Converted = vbNewLine & json_Indentation & json_Converted
425426
End If
426427

427-
cSA.Append json_Converted
428+
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
428429
Next json_Value
429430

430431
If json_PrettyPrint Then
431-
cSA.Append vbNewLine
432+
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
432433

433434
If VBA.VarType(Whitespace) = VBA.vbString Then
434435
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
@@ -437,10 +438,10 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
437438
End If
438439
End If
439440

440-
cSA.Append json_Indentation & "]"
441+
json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
441442
End If
442443

443-
ConvertToJson = cSA.Report
444+
ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition, json_BufferLength)
444445
Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal
445446
' Number (use decimals for numbers)
446447
ConvertToJson = VBA.Replace(JsonValue, ",", ".")
@@ -544,7 +545,9 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon
544545
Dim json_Quote As String
545546
Dim json_Char As String
546547
Dim json_Code As String
547-
Dim cSA As New clsStringAppend
548+
Dim json_Buffer As String
549+
Dim json_BufferPosition As Long
550+
Dim json_BufferLength As Long
548551

549552
json_SkipSpaces json_String, json_Index
550553

@@ -563,36 +566,36 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon
563566

564567
Select Case json_Char
565568
Case """", "\", "/", "'"
566-
cSA.Append json_Char
569+
json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
567570
json_Index = json_Index + 1
568571
Case "b"
569-
cSA.Append vbBack
572+
json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength
570573
json_Index = json_Index + 1
571574
Case "f"
572-
cSA.Append vbFormFeed
575+
json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength
573576
json_Index = json_Index + 1
574577
Case "n"
575-
cSA.Append vbCrLf
578+
json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength
576579
json_Index = json_Index + 1
577580
Case "r"
578-
cSA.Append vbCr
581+
json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength
579582
json_Index = json_Index + 1
580583
Case "t"
581-
cSA.Append vbTab
584+
json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength
582585
json_Index = json_Index + 1
583586
Case "u"
584587
' Unicode character escape (e.g. \u00a9 = Copyright)
585588
json_Index = json_Index + 1
586589
json_Code = VBA.Mid$(json_String, json_Index, 4)
587-
cSA.Append VBA.ChrW(VBA.Val("&h" + json_Code))
590+
json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength
588591
json_Index = json_Index + 4
589592
End Select
590593
Case json_Quote
591-
json_ParseString = cSA.Report
594+
json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition, json_BufferLength)
592595
json_Index = json_Index + 1
593596
Exit Function
594597
Case Else
595-
cSA.Append json_Char
598+
json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
596599
json_Index = json_Index + 1
597600
End Select
598601
Loop
@@ -678,7 +681,9 @@ Private Function json_Encode(ByVal json_Text As Variant) As String
678681
Dim json_Index As Long
679682
Dim json_Char As String
680683
Dim json_AscCode As Long
681-
Dim cSA As New clsStringAppend
684+
Dim json_Buffer As String
685+
Dim json_BufferPosition As Long
686+
Dim json_BufferLength As Long
682687

683688
For json_Index = 1 To VBA.Len(json_Text)
684689
json_Char = VBA.Mid$(json_Text, json_Index, 1)
@@ -725,10 +730,10 @@ Private Function json_Encode(ByVal json_Text As Variant) As String
725730
json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4)
726731
End Select
727732

728-
cSA.Append json_Char
733+
json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
729734
Next json_Index
730735

731-
json_Encode = cSA.Report
736+
json_Encode = json_BufferToString(json_Buffer, json_BufferPosition, json_BufferLength)
732737
End Function
733738

734739
Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String
@@ -801,10 +806,62 @@ Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index
801806
ErrorMessage
802807
End Function
803808

809+
Private Sub json_BufferAppend(ByRef json_Buffer As String, _
810+
ByRef json_Append As Variant, _
811+
ByRef json_BufferPosition As Long, _
812+
ByRef json_BufferLength As Long)
813+
' VBA can be slow to append strings due to allocating a new string for each append
814+
' Instead of using the traditional append, allocate a large empty string and then copy string at append position
815+
'
816+
' Example:
817+
' Buffer: "abc "
818+
' Append: "def"
819+
' Buffer Position: 3
820+
' Buffer Length: 5
821+
'
822+
' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer
823+
' Buffer: "abc "
824+
' Buffer Length: 10
825+
'
826+
' Put "def" into buffer at position 3 (0-based)
827+
' Buffer: "abcdef "
828+
'
829+
' Approach based on cStringBuilder from vbAccelerator
830+
' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp
831+
'
832+
' and clsStringAppend from Philip Swannell
833+
' https://github.com/VBA-tools/VBA-JSON/pull/82
834+
835+
Dim json_AppendLength As Long
836+
Dim json_LengthPlusPosition As Long
804837

838+
json_AppendLength = VBA.Len(json_Append)
839+
json_LengthPlusPosition = json_AppendLength + json_BufferPosition
840+
841+
If json_LengthPlusPosition > json_BufferLength Then
842+
' Appending would overflow buffer, add chunk
843+
' (double buffer length or append length, whichever is bigger)
844+
Dim json_AddedLength As Long
845+
json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength)
846+
847+
json_Buffer = json_Buffer & VBA.Space$(json_AddedLength)
848+
json_BufferLength = json_BufferLength + json_AddedLength
849+
End If
850+
851+
' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error:
852+
' Function call on left-hand side of assignment must return Variant or Object
853+
Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append)
854+
json_BufferPosition = json_BufferPosition + json_AppendLength
855+
End Sub
856+
857+
Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long, ByVal json_BufferLength As Long) As String
858+
If json_BufferPosition > 0 Then
859+
json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition)
860+
End If
861+
End Function
805862

806863
''
807-
' VBA-UTC v1.0.3
864+
' VBA-UTC v1.0.5
808865
' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter
809866
'
810867
' UTC/ISO 8601 Converter for VBA
@@ -952,7 +1009,7 @@ Public Function ParseIso(utc_IsoString As String) As Date
9521009
ParseIso = ParseUtc(ParseIso)
9531010

9541011
If utc_HasOffset Then
955-
ParseIso = ParseIso + utc_Offset
1012+
ParseIso = ParseIso - utc_Offset
9561013
End If
9571014
End If
9581015

@@ -1036,15 +1093,15 @@ Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResu
10361093

10371094
Do While utc_feof(utc_File) = 0
10381095
utc_Chunk = VBA.Space$(50)
1039-
utc_Read = utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File)
1096+
utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File))
10401097
If utc_Read > 0 Then
1041-
utc_Chunk = VBA.Left$(utc_Chunk, utc_Read)
1098+
utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read))
10421099
utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk
10431100
End If
10441101
Loop
10451102

10461103
utc_ErrorHandling:
1047-
utc_ExecuteInShell.utc_ExitCode = utc_pclose(utc_File)
1104+
utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File))
10481105
End Function
10491106

10501107
#Else
@@ -1065,9 +1122,3 @@ Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date
10651122
End Function
10661123

10671124
#End If
1068-
1069-
1070-
1071-
1072-
1073-

0 commit comments

Comments
 (0)