Skip to content

Commit bcbdfe2

Browse files
timhalltimhall
committed
Update VBA-JSON to v2.3.0
Closes #341 Closes #345
1 parent 459fa26 commit bcbdfe2

File tree

1 file changed

+55
-103
lines changed

1 file changed

+55
-103
lines changed

‎src/WebHelpers.bas‎

Lines changed: 55 additions & 103 deletions
Original file line numberDiff line numberDiff line change
@@ -236,19 +236,6 @@ End Type
236236
#End If
237237
' === End VBA-UTC
238238

239-
#If Mac Then
240-
#ElseIf VBA7 Then
241-
242-
Private Declare PtrSafe Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
243-
(json_MemoryDestination As Any, json_MemorySource As Any, ByVal json_ByteLength As Long)
244-
245-
#Else
246-
247-
Private Declare Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
248-
(json_MemoryDestination As Any, json_MemorySource As Any, ByVal json_ByteLength As Long)
249-
250-
#End If
251-
252239
Private Type json_Options
253240
' VBA only stores 15 significant digits, so any numbers larger than that are truncated
254241
' 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
@@ -1990,7 +1977,7 @@ Private Function web_GetUrlEncodedKeyValue(Key As Variant, Value As Variant, Opt
19901977
End Function
19911978

19921979
''
1993-
' VBA-JSON v2.2.4
1980+
' VBA-JSON v2.3.0
19941981
' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON
19951982
'
19961983
' JSON Converter for VBA
@@ -2076,7 +2063,7 @@ End Function
20762063
' @return {String}
20772064
''
20782065
Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String
2079-
Dim json_buffer As String
2066+
Dim json_Buffer As String
20802067
Dim json_BufferPosition As Long
20812068
Dim json_BufferLength As Long
20822069
Dim json_Index As Long
@@ -2137,7 +2124,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
21372124
End If
21382125

21392126
' Array
2140-
json_BufferAppend json_buffer, "[", json_BufferPosition, json_BufferLength
2127+
json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength
21412128

21422129
On Error Resume Next
21432130

@@ -2152,21 +2139,21 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
21522139
json_IsFirstItem = False
21532140
Else
21542141
' Append comma to previous line
2155-
json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength
2142+
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
21562143
End If
21572144

21582145
If json_LBound2D >= 0 And json_UBound2D >= 0 Then
21592146
' 2D Array
21602147
If json_PrettyPrint Then
2161-
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
2148+
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
21622149
End If
2163-
json_BufferAppend json_buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength
2150+
json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength
21642151

21652152
For json_Index2D = json_LBound2D To json_UBound2D
21662153
If json_IsFirstItem2D Then
21672154
json_IsFirstItem2D = False
21682155
Else
2169-
json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength
2156+
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
21702157
End If
21712158

21722159
json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2)
@@ -2183,14 +2170,14 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
21832170
json_Converted = vbNewLine & json_InnerIndentation & json_Converted
21842171
End If
21852172

2186-
json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength
2173+
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
21872174
Next json_Index2D
21882175

21892176
If json_PrettyPrint Then
2190-
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
2177+
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
21912178
End If
21922179

2193-
json_BufferAppend json_buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
2180+
json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
21942181
json_IsFirstItem2D = True
21952182
Else
21962183
' 1D Array
@@ -2208,15 +2195,15 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
22082195
json_Converted = vbNewLine & json_Indentation & json_Converted
22092196
End If
22102197

2211-
json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength
2198+
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
22122199
End If
22132200
Next json_Index
22142201
End If
22152202

22162203
On Error GoTo 0
22172204

22182205
If json_PrettyPrint Then
2219-
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
2206+
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
22202207

22212208
If VBA.VarType(Whitespace) = VBA.vbString Then
22222209
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
@@ -2225,9 +2212,9 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
22252212
End If
22262213
End If
22272214

2228-
json_BufferAppend json_buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
2215+
json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
22292216

2230-
ConvertToJson = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
2217+
ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)
22312218

22322219
' Dictionary or Collection
22332220
Case VBA.vbObject
@@ -2241,7 +2228,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
22412228

22422229
' Dictionary
22432230
If VBA.TypeName(JsonValue) = "Dictionary" Then
2244-
json_BufferAppend json_buffer, "{", json_BufferPosition, json_BufferLength
2231+
json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength
22452232
For Each json_Key In JsonValue.Keys
22462233
' For Objects, undefined (Empty/Nothing) is not added to object
22472234
json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1)
@@ -2255,7 +2242,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
22552242
If json_IsFirstItem Then
22562243
json_IsFirstItem = False
22572244
Else
2258-
json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength
2245+
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
22592246
End If
22602247

22612248
If json_PrettyPrint Then
@@ -2264,12 +2251,12 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
22642251
json_Converted = """" & json_Key & """:" & json_Converted
22652252
End If
22662253

2267-
json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength
2254+
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
22682255
End If
22692256
Next json_Key
22702257

22712258
If json_PrettyPrint Then
2272-
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
2259+
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
22732260

22742261
If VBA.VarType(Whitespace) = VBA.vbString Then
22752262
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
@@ -2278,16 +2265,16 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
22782265
End If
22792266
End If
22802267

2281-
json_BufferAppend json_buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength
2268+
json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength
22822269

22832270
' Collection
22842271
ElseIf VBA.TypeName(JsonValue) = "Collection" Then
2285-
json_BufferAppend json_buffer, "[", json_BufferPosition, json_BufferLength
2272+
json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength
22862273
For Each json_Value In JsonValue
22872274
If json_IsFirstItem Then
22882275
json_IsFirstItem = False
22892276
Else
2290-
json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength
2277+
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
22912278
End If
22922279

22932280
json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1)
@@ -2304,11 +2291,11 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
23042291
json_Converted = vbNewLine & json_Indentation & json_Converted
23052292
End If
23062293

2307-
json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength
2294+
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
23082295
Next json_Value
23092296

23102297
If json_PrettyPrint Then
2311-
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
2298+
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
23122299

23132300
If VBA.VarType(Whitespace) = VBA.vbString Then
23142301
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
@@ -2317,10 +2304,10 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
23172304
End If
23182305
End If
23192306

2320-
json_BufferAppend json_buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
2307+
json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
23212308
End If
23222309

2323-
ConvertToJson = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
2310+
ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)
23242311
Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal
23252312
' Number (use decimals for numbers)
23262313
ConvertToJson = VBA.Replace(JsonValue, ",", ".")
@@ -2424,7 +2411,7 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon
24242411
Dim json_Quote As String
24252412
Dim json_Char As String
24262413
Dim json_Code As String
2427-
Dim json_buffer As String
2414+
Dim json_Buffer As String
24282415
Dim json_BufferPosition As Long
24292416
Dim json_BufferLength As Long
24302417

@@ -2445,36 +2432,36 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon
24452432

24462433
Select Case json_Char
24472434
Case """", "\", "/", "'"
2448-
json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
2435+
json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
24492436
json_Index = json_Index + 1
24502437
Case "b"
2451-
json_BufferAppend json_buffer, vbBack, json_BufferPosition, json_BufferLength
2438+
json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength
24522439
json_Index = json_Index + 1
24532440
Case "f"
2454-
json_BufferAppend json_buffer, vbFormFeed, json_BufferPosition, json_BufferLength
2441+
json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength
24552442
json_Index = json_Index + 1
24562443
Case "n"
2457-
json_BufferAppend json_buffer, vbCrLf, json_BufferPosition, json_BufferLength
2444+
json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength
24582445
json_Index = json_Index + 1
24592446
Case "r"
2460-
json_BufferAppend json_buffer, vbCr, json_BufferPosition, json_BufferLength
2447+
json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength
24612448
json_Index = json_Index + 1
24622449
Case "t"
2463-
json_BufferAppend json_buffer, vbTab, json_BufferPosition, json_BufferLength
2450+
json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength
24642451
json_Index = json_Index + 1
24652452
Case "u"
24662453
' Unicode character escape (e.g. \u00a9 = Copyright)
24672454
json_Index = json_Index + 1
24682455
json_Code = VBA.Mid$(json_String, json_Index, 4)
2469-
json_BufferAppend json_buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength
2456+
json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength
24702457
json_Index = json_Index + 4
24712458
End Select
24722459
Case json_Quote
2473-
json_ParseString = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
2460+
json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition)
24742461
json_Index = json_Index + 1
24752462
Exit Function
24762463
Case Else
2477-
json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
2464+
json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
24782465
json_Index = json_Index + 1
24792466
End Select
24802467
Loop
@@ -2560,7 +2547,7 @@ Private Function json_Encode(ByVal json_Text As Variant) As String
25602547
Dim json_Index As Long
25612548
Dim json_Char As String
25622549
Dim json_AscCode As Long
2563-
Dim json_buffer As String
2550+
Dim json_Buffer As String
25642551
Dim json_BufferPosition As Long
25652552
Dim json_BufferLength As Long
25662553

@@ -2609,10 +2596,10 @@ Private Function json_Encode(ByVal json_Text As Variant) As String
26092596
json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4)
26102597
End Select
26112598

2612-
json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
2599+
json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
26132600
Next json_Index
26142601

2615-
json_Encode = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
2602+
json_Encode = json_BufferToString(json_Buffer, json_BufferPosition)
26162603
End Function
26172604

26182605
Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String
@@ -2639,7 +2626,6 @@ Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean
26392626
' Length with be at least 16 characters and assume will be less than 100 characters
26402627
If json_Length >= 16 And json_Length <= 100 Then
26412628
Dim json_CharCode As String
2642-
Dim json_Index As Long
26432629

26442630
json_StringIsLargeNumber = True
26452631

@@ -2685,13 +2671,10 @@ Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index
26852671
ErrorMessage
26862672
End Function
26872673

2688-
Private Sub json_BufferAppend(ByRef json_buffer As String, _
2674+
Private Sub json_BufferAppend(ByRef json_Buffer As String, _
26892675
ByRef json_Append As Variant, _
26902676
ByRef json_BufferPosition As Long, _
26912677
ByRef json_BufferLength As Long)
2692-
#If Mac Then
2693-
json_buffer = json_buffer & json_Append
2694-
#Else
26952678
' VBA can be slow to append strings due to allocating a new string for each append
26962679
' Instead of using the traditional append, allocate a large empty string and then copy string at append position
26972680
'
@@ -2705,71 +2688,40 @@ Private Sub json_BufferAppend(ByRef json_buffer As String, _
27052688
' Buffer: "abc "
27062689
' Buffer Length: 10
27072690
'
2708-
' Copy memory for "def" into buffer at position 3 (0-based)
2691+
' Put "def" into buffer at position 3 (0-based)
27092692
' Buffer: "abcdef "
27102693
'
27112694
' Approach based on cStringBuilder from vbAccelerator
27122695
' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp
2696+
'
2697+
' and clsStringAppend from Philip Swannell
2698+
' https://github.com/VBA-tools/VBA-JSON/pull/82
27132699

27142700
Dim json_AppendLength As Long
27152701
Dim json_LengthPlusPosition As Long
27162702

2717-
json_AppendLength = VBA.LenB(json_Append)
2703+
json_AppendLength = VBA.Len(json_Append)
27182704
json_LengthPlusPosition = json_AppendLength + json_BufferPosition
27192705

27202706
If json_LengthPlusPosition > json_BufferLength Then
2721-
' Appending would overflow buffer, add chunks until buffer is long enough
2722-
Dim json_TemporaryLength As Long
2723-
2724-
json_TemporaryLength = json_BufferLength
2725-
Do While json_TemporaryLength < json_LengthPlusPosition
2726-
' Initially, initialize string with 255 characters,
2727-
' then add large chunks (8192) after that
2728-
'
2729-
' Size: # Characters x 2 bytes / character
2730-
If json_TemporaryLength = 0 Then
2731-
json_TemporaryLength = json_TemporaryLength + 510
2732-
Else
2733-
json_TemporaryLength = json_TemporaryLength + 16384
2734-
End If
2735-
Loop
2707+
' Appending would overflow buffer, add chunk
2708+
' (double buffer length or append length, whichever is bigger)
2709+
Dim json_AddedLength As Long
2710+
json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength)
27362711

2737-
json_buffer = json_buffer & VBA.Space$((json_TemporaryLength - json_BufferLength) \ 2)
2738-
json_BufferLength = json_TemporaryLength
2712+
json_Buffer = json_Buffer & VBA.Space$(json_AddedLength)
2713+
json_BufferLength = json_BufferLength + json_AddedLength
27392714
End If
27402715

2741-
' Copy memory from append to buffer at buffer position
2742-
json_CopyMemory ByVal json_UnsignedAdd(StrPtr(json_buffer), _
2743-
json_BufferPosition), _
2744-
ByVal StrPtr(json_Append), _
2745-
json_AppendLength
2746-
2716+
' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error:
2717+
' Function call on left-hand side of assignment must return Variant or Object
2718+
Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append)
27472719
json_BufferPosition = json_BufferPosition + json_AppendLength
2748-
#End If
27492720
End Sub
27502721

2751-
Private Function json_BufferToString(ByRef json_buffer As String, ByVal json_BufferPosition As Long, ByVal json_BufferLength As Long) As String
2752-
#If Mac Then
2753-
json_BufferToString = json_buffer
2754-
#Else
2722+
Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String
27552723
If json_BufferPosition > 0 Then
2756-
json_BufferToString = VBA.Left$(json_buffer, json_BufferPosition \ 2)
2757-
End If
2758-
#End If
2759-
End Function
2760-
2761-
#If VBA7 Then
2762-
Private Function json_UnsignedAdd(json_Start As LongPtr, json_Increment As Long) As LongPtr
2763-
#Else
2764-
Private Function json_UnsignedAdd(json_Start As Long, json_Increment As Long) As Long
2765-
#End If
2766-
2767-
If json_Start And &H80000000 Then
2768-
json_UnsignedAdd = json_Start + json_Increment
2769-
ElseIf (json_Start Or &H80000000) < -json_Increment Then
2770-
json_UnsignedAdd = json_Start + json_Increment
2771-
Else
2772-
json_UnsignedAdd = (json_Start + &H80000000) + (json_Increment + &H80000000)
2724+
json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition)
27732725
End If
27742726
End Function
27752727

0 commit comments

Comments
 (0)