├── specs ├── VBA-JSON - Specs.xlsm └── Specs.bas ├── .gitignore ├── .editorconfig ├── vba-block.toml ├── .gitattributes ├── LICENSE ├── README.md └── JsonConverter.bas /specs/VBA-JSON - Specs.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/VBA-tools/VBA-JSON/HEAD/specs/VBA-JSON - Specs.xlsm -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | build 2 | 3 | # Ignore temporary Excel files 4 | */~$* 5 | 6 | # Ignore scratch work and other files 7 | _scratch 8 | .DS_Store 9 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | [*] 2 | indent_style = space 3 | indent_size = 2 4 | end_of_line = lf 5 | trim_trailing_whitespace = true 6 | insert_final_newline = true 7 | charset = utf-8 8 | 9 | [*.{bas,cls}] 10 | indent_size = 4 11 | end_of_line = crlf 12 | -------------------------------------------------------------------------------- /vba-block.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "json" 3 | version = "2.2.3" 4 | authors = ["Tim Hall (https://github.com/timhall)"] 5 | 6 | [src] 7 | JsonConverter = "JsonConverter.bas" 8 | 9 | [dependencies] 10 | dictionary = "^1" 11 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # CRLF -> LF by default, but not for modules or classes (especially classes) 2 | * text=auto 3 | *.bas text eol=crlf 4 | *.cls text eol=crlf 5 | 6 | # Standard to msysgit 7 | *.doc diff=astextplain 8 | *.DOC diff=astextplain 9 | *.docx diff=astextplain 10 | *.DOCX diff=astextplain 11 | *.dot diff=astextplain 12 | *.DOT diff=astextplain 13 | *.pdf diff=astextplain 14 | *.PDF diff=astextplain 15 | *.rtf diff=astextplain 16 | *.RTF diff=astextplain 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016-2019 Tim Hall 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # VBA-JSON 2 | 3 | JSON conversion and parsing for VBA (Windows and Mac Excel, Access, and other Office applications). 4 | It grew out of the excellent project [vba-json](https://code.google.com/p/vba-json/), 5 | with additions and improvements made to resolve bugs and improve performance (as part of [VBA-Web](https://github.com/VBA-tools/VBA-Web)). 6 | 7 | Tested in Windows Excel 2013 and Excel for Mac 2011, but should apply to 2007+. 8 | 9 | - For Windows-only support, include a reference to "Microsoft Scripting Runtime" 10 | - For Mac and Windows support, include [VBA-Dictionary](https://github.com/VBA-tools/VBA-Dictionary) 11 | 12 | 13 | Donate 14 | 15 | 16 | # Examples 17 | 18 | ```vb 19 | Dim Json As Object 20 | Set Json = JsonConverter.ParseJson("{""a"":123,""b"":[1,2,3,4],""c"":{""d"":456}}") 21 | 22 | ' Json("a") -> 123 23 | ' Json("b")(2) -> 2 24 | ' Json("c")("d") -> 456 25 | Json("c")("e") = 789 26 | 27 | Debug.Print JsonConverter.ConvertToJson(Json) 28 | ' -> "{"a":123,"b":[1,2,3,4],"c":{"d":456,"e":789}}" 29 | 30 | Debug.Print JsonConverter.ConvertToJson(Json, Whitespace:=2) 31 | ' -> "{ 32 | ' "a": 123, 33 | ' "b": [ 34 | ' 1, 35 | ' 2, 36 | ' 3, 37 | ' 4 38 | ' ], 39 | ' "c": { 40 | ' "d": 456, 41 | ' "e": 789 42 | ' } 43 | ' }" 44 | ``` 45 | 46 | ```vb 47 | ' Advanced example: Read .json file and load into sheet (Windows-only) 48 | ' (add reference to Microsoft Scripting Runtime) 49 | ' {"values":[{"a":1,"b":2,"c": 3},...]} 50 | 51 | Dim FSO As New FileSystemObject 52 | Dim JsonTS As TextStream 53 | Dim JsonText As String 54 | Dim Parsed As Dictionary 55 | 56 | ' Read .json file 57 | Set JsonTS = FSO.OpenTextFile("example.json", ForReading) 58 | JsonText = JsonTS.ReadAll 59 | JsonTS.Close 60 | 61 | ' Parse json to Dictionary 62 | ' "values" is parsed as Collection 63 | ' each item in "values" is parsed as Dictionary 64 | Set Parsed = JsonConverter.ParseJson(JsonText) 65 | 66 | ' Prepare and write values to sheet 67 | Dim Values As Variant 68 | ReDim Values(Parsed("values").Count, 3) 69 | 70 | Dim Value As Dictionary 71 | Dim i As Long 72 | 73 | i = 0 74 | For Each Value In Parsed("values") 75 | Values(i, 0) = Value("a") 76 | Values(i, 1) = Value("b") 77 | Values(i, 2) = Value("c") 78 | i = i + 1 79 | Next Value 80 | 81 | Sheets("example").Range(Cells(1, 1), Cells(Parsed("values").Count, 3)) = Values 82 | ``` 83 | 84 | ## Options 85 | 86 | VBA-JSON includes a few options for customizing parsing/conversion if needed: 87 | 88 | - __UseDoubleForLargeNumbers__ (Default = `False`) VBA only stores 15 significant digits, so any numbers larger than that are truncated. 89 | 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. 90 | By default, VBA-JSON will use `String` for numbers longer than 15 characters that contain only digits, use this option to use `Double` instead. 91 | - __AllowUnquotedKeys__ (Default = `False`) The JSON standard requires object keys to be quoted (`"` or `'`), use this option to allow unquoted keys. 92 | - __EscapeSolidus__ (Default = `False`) The solidus (`/`) is not required to be escaped, use this option to escape them as `\/` in `ConvertToJson`. 93 | 94 | ```VB.net 95 | JsonConverter.JsonOptions.EscapeSolidus = True 96 | ``` 97 | 98 | ## Installation 99 | 100 | 1. Download the [latest release](https://github.com/VBA-tools/VBA-JSON/releases) 101 | 2. Import `JsonConverter.bas` into your project (Open VBA Editor, `Alt + F11`; File > Import File) 102 | 3. Add `Dictionary` reference/class 103 | - For Windows-only, include a reference to "Microsoft Scripting Runtime" 104 | - For Windows and Mac, include [VBA-Dictionary](https://github.com/VBA-tools/VBA-Dictionary) 105 | 106 | ## Resources 107 | 108 | - [Tutorial Video (Red Stapler)](https://youtu.be/CFFLRmHsEAs) 109 | -------------------------------------------------------------------------------- /specs/Specs.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Specs" 2 | Public Function Specs() As SpecSuite 3 | Set Specs = New SpecSuite 4 | Specs.Description = "VBA-JSON" 5 | 6 | On Error Resume Next 7 | 8 | Dim JsonString As String 9 | Dim JsonObject As Object 10 | Dim NestedObject As Object 11 | Dim EmptyVariant As Variant 12 | Dim NothingObject As Object 13 | 14 | Dim MultiDimensionalArray(1, 1) As Variant 15 | 16 | ' ============================================= ' 17 | ' ParseJson 18 | ' ============================================= ' 19 | 20 | With Specs.It("should parse object string") 21 | JsonString = "{""a"":1,""b"":3.14,""c"":""abc"",""d"":false,""e"":[1,3.14,""abc"",false,[1,2,3],{""a"":1}],""f"":{""a"":1},""g"":null}" 22 | Set JsonObject = JsonConverter.ParseJson(JsonString) 23 | 24 | .Expect(JsonObject).ToNotBeUndefined 25 | .Expect(JsonObject("a")).ToEqual 1 26 | .Expect(JsonObject("b")).ToEqual 3.14 27 | .Expect(JsonObject("c")).ToEqual "abc" 28 | .Expect(JsonObject("d")).ToEqual False 29 | 30 | .Expect(JsonObject("e")).ToNotBeUndefined 31 | .Expect(JsonObject("e")(1)).ToEqual 1 32 | .Expect(JsonObject("e")(2)).ToEqual 3.14 33 | .Expect(JsonObject("e")(3)).ToEqual "abc" 34 | .Expect(JsonObject("e")(4)).ToEqual False 35 | .Expect(JsonObject("e")(5)).ToNotBeUndefined 36 | .Expect(JsonObject("e")(5)(1)).ToEqual 1 37 | .Expect(JsonObject("e")(5)(2)).ToEqual 2 38 | .Expect(JsonObject("e")(5)(3)).ToEqual 3 39 | .Expect(JsonObject("e")(6)).ToNotBeUndefined 40 | .Expect(JsonObject("e")(6)("a")).ToEqual 1 41 | 42 | .Expect(JsonObject("f")).ToNotBeUndefined 43 | .Expect(JsonObject("f")("a")).ToEqual 1 44 | 45 | .Expect(JsonObject("g")).ToBeNull 46 | End With 47 | 48 | With Specs.It("should parse array string") 49 | JsonString = "[1,3.14,""abc"",false,[1,2,3],{""a"":1},null]" 50 | Set JsonObject = JsonConverter.ParseJson(JsonString) 51 | 52 | .Expect(JsonObject).ToNotBeUndefined 53 | .Expect(JsonObject(1)).ToEqual 1 54 | .Expect(JsonObject(2)).ToEqual 3.14 55 | .Expect(JsonObject(3)).ToEqual "abc" 56 | .Expect(JsonObject(4)).ToEqual False 57 | .Expect(JsonObject(5)).ToNotBeUndefined 58 | .Expect(JsonObject(5)(1)).ToEqual 1 59 | .Expect(JsonObject(5)(2)).ToEqual 2 60 | .Expect(JsonObject(5)(3)).ToEqual 3 61 | .Expect(JsonObject(6)).ToNotBeUndefined 62 | .Expect(JsonObject(6)("a")).ToEqual 1 63 | .Expect(JsonObject(7)).ToBeNull 64 | End With 65 | 66 | With Specs.It("should parse nested array string") 67 | JsonString = "[[[1,2,3],4],5]" 68 | Set JsonObject = JsonConverter.ParseJson(JsonString) 69 | 70 | .Expect(JsonObject).ToNotBeUndefined 71 | .Expect(JsonObject(1)).ToNotBeUndefined 72 | .Expect(JsonObject(1)(1)).ToNotBeUndefined 73 | .Expect(JsonObject(1)(1)(1)).ToEqual 1 74 | .Expect(JsonObject(1)(1)(2)).ToEqual 2 75 | .Expect(JsonObject(1)(1)(3)).ToEqual 3 76 | .Expect(JsonObject(1)(2)).ToEqual 4 77 | .Expect(JsonObject(2)).ToEqual 5 78 | End With 79 | 80 | With Specs.It("should parse escaped single quote in key and value") 81 | ' Checks https://code.google.com/p/vba-json/issues/detail?id=2 82 | JsonString = "{'a\'b':'c\'d'}" 83 | Set JsonObject = JsonConverter.ParseJson(JsonString) 84 | 85 | .Expect(JsonObject).ToNotBeUndefined 86 | .Expect(JsonObject.Exists("a'b")).ToEqual True 87 | .Expect(JsonObject("a'b")).ToEqual "c'd" 88 | End With 89 | 90 | With Specs.It("should parse nested objects and arrays") 91 | ' Checks https://code.google.com/p/vba-json/issues/detail?id=7 92 | JsonString = "{""total_rows"":36778,""offset"":26220,""rows"":[" & vbNewLine & _ 93 | "{""id"":""6b80c0b76"",""key"":""a@bbb.net"",""value"":{""entryid"":""81151F241C2500"",""subject"":""test subject"",""senton"":""2009-7-09 22:03:43""}}," & vbNewLine & _ 94 | "{""id"":""b10ed9bee"",""key"":""b@bbb.net"",""value"":{""entryid"":""A7C3CF74EA95C9F"",""subject"":""test subject2"",""senton"":""2009-4-21 10:18:26""}}" & vbNewLine & _ 95 | "]}" 96 | Set JsonObject = JsonConverter.ParseJson(JsonString) 97 | 98 | .Expect(JsonObject).ToNotBeUndefined 99 | .Expect(JsonObject("offset")).ToEqual 26220 100 | .Expect(JsonObject("rows")(2)("key")).ToEqual "b@bbb.net" 101 | End With 102 | 103 | With Specs.It("should handle very long numbers as strings (e.g. BIGINT)") 104 | JsonString = "[123456789012345678901234567890, 1.123456789012345678901234567890, 123456789012345, 1.23456789012345]" 105 | Set JsonObject = JsonConverter.ParseJson(JsonString) 106 | 107 | .Expect(JsonObject).ToNotBeUndefined 108 | .Expect(JsonObject(1)).ToEqual "123456789012345678901234567890" 109 | .Expect(JsonObject(2)).ToEqual "1.123456789012345678901234567890" 110 | .Expect(JsonObject(3)).ToEqual 123456789012345# 111 | .Expect(JsonObject(4)).ToEqual 1.23456789012345 112 | 113 | JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True 114 | JsonString = "[123456789012345678901234567890]" 115 | Set JsonObject = JsonConverter.ParseJson(JsonString) 116 | 117 | .Expect(JsonObject).ToNotBeUndefined 118 | .Expect(JsonObject(1)).ToEqual 1.23456789012346E+29 119 | JsonConverter.JsonOptions.UseDoubleForLargeNumbers = False 120 | End With 121 | 122 | With Specs.It("should parse double-backslash as backslash") 123 | ' Checks https://code.google.com/p/vba-json/issues/detail?id=11 124 | JsonString = "[""C:\\folder\\picture.jpg""]" 125 | Set JsonObject = JsonConverter.ParseJson(JsonString) 126 | 127 | .Expect(JsonObject).ToNotBeUndefined 128 | .Expect(JsonObject(1)).ToEqual "C:\folder\picture.jpg" 129 | End With 130 | 131 | With Specs.It("should allow keys and values with colons") 132 | ' Checks https://code.google.com/p/vba-json/issues/detail?id=14 133 | JsonString = "{""a:b"":""c:d""}" 134 | Set JsonObject = JsonConverter.ParseJson(JsonString) 135 | 136 | .Expect(JsonObject).ToNotBeUndefined 137 | .Expect(JsonObject.Exists("a:b")).ToEqual True 138 | .Expect(JsonObject("a:b")).ToEqual "c:d" 139 | End With 140 | 141 | With Specs.It("should allow spaces in keys") 142 | ' Checks https://code.google.com/p/vba-json/issues/detail?id=19 143 | JsonString = "{""a b c"":""d e f""}" 144 | Set JsonObject = JsonConverter.ParseJson(JsonString) 145 | 146 | .Expect(JsonObject).ToNotBeUndefined 147 | .Expect(JsonObject.Exists("a b c")).ToEqual True 148 | .Expect(JsonObject("a b c")).ToEqual "d e f" 149 | End With 150 | 151 | With Specs.It("should allow unquoted keys with option") 152 | JsonConverter.JsonOptions.AllowUnquotedKeys = True 153 | JsonString = "{a:""a"",b :""b""}" 154 | Set JsonObject = JsonConverter.ParseJson(JsonString) 155 | 156 | .Expect(JsonObject).ToNotBeUndefined 157 | .Expect(JsonObject.Exists("a")).ToEqual True 158 | .Expect(JsonObject("a")).ToEqual "a" 159 | .Expect(JsonObject.Exists("b")).ToEqual True 160 | .Expect(JsonObject("b")).ToEqual "b" 161 | JsonConverter.JsonOptions.AllowUnquotedKeys = False 162 | End With 163 | 164 | ' ============================================= ' 165 | ' ConvertToJson 166 | ' ============================================= ' 167 | 168 | With Specs.It("should convert object to string") 169 | Set JsonObject = New Dictionary 170 | JsonObject.Add "a", 1 171 | JsonObject.Add "b", 3.14 172 | JsonObject.Add "c", "abc" 173 | JsonObject.Add "d", False 174 | JsonObject.Add "e", New Collection 175 | JsonObject("e").Add 1 176 | JsonObject("e").Add 3.14 177 | JsonObject("e").Add "abc" 178 | JsonObject("e").Add False 179 | JsonObject("e").Add Array(1, 2, 3) 180 | JsonObject("e").Add New Dictionary 181 | JsonObject("e")(6).Add "a", 1 182 | JsonObject.Add "f", New Dictionary 183 | JsonObject("f").Add "a", 1 184 | JsonObject.Add "g", Null 185 | 186 | JsonString = JsonConverter.ConvertToJson(JsonObject) 187 | .Expect(JsonString).ToEqual "{""a"":1,""b"":3.14,""c"":""abc"",""d"":false,""e"":[1,3.14,""abc"",false,[1,2,3],{""a"":1}],""f"":{""a"":1},""g"":null}" 188 | End With 189 | 190 | With Specs.It("should convert collection to string") 191 | Set JsonObject = New Collection 192 | JsonObject.Add 1 193 | JsonObject.Add 3.14 194 | JsonObject.Add "abc" 195 | JsonObject.Add False 196 | JsonObject.Add Array(1, 2, 3) 197 | JsonObject.Add New Dictionary 198 | JsonObject(6).Add "a", 1 199 | JsonObject.Add Null 200 | 201 | JsonString = JsonConverter.ConvertToJson(JsonObject) 202 | .Expect(JsonString).ToEqual "[1,3.14,""abc"",false,[1,2,3],{""a"":1},null]" 203 | End With 204 | 205 | With Specs.It("should convert array to string") 206 | JsonString = JsonConverter.ConvertToJson(Array(1, 3.14, "abc", False, Array(1, 2, 3))) 207 | .Expect(JsonString).ToEqual "[1,3.14,""abc"",false,[1,2,3]]" 208 | End With 209 | 210 | With Specs.It("should convert very long numbers as strings (e.g. BIGINT)") 211 | JsonString = JsonConverter.ConvertToJson(Array("123456789012345678901234567890", "1.123456789012345678901234567890", "1234567890123456F")) 212 | .Expect(JsonString).ToEqual "[123456789012345678901234567890,1.123456789012345678901234567890,""1234567890123456F""]" 213 | 214 | JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True 215 | JsonString = JsonConverter.ConvertToJson(Array("123456789012345678901234567890")) 216 | .Expect(JsonString).ToEqual "[""123456789012345678901234567890""]" 217 | JsonConverter.JsonOptions.UseDoubleForLargeNumbers = False 218 | End With 219 | 220 | With Specs.It("should convert dates to ISO 8601") 221 | JsonString = JsonConverter.ConvertToJson(DateSerial(2003, 1, 15) + TimeSerial(12, 5, 6)) 222 | 223 | ' Due to UTC conversion, test shape and year, month, and seconds 224 | .Expect(JsonString).ToMatch "2003-01-" 225 | .Expect(JsonString).ToMatch "T" 226 | .Expect(JsonString).ToMatch ":06.000Z" 227 | End With 228 | 229 | With Specs.It("should convert 2D arrays") 230 | ' Checks https://code.google.com/p/vba-json/issues/detail?id=8 231 | MultiDimensionalArray(0, 0) = 1 232 | MultiDimensionalArray(0, 1) = 2 233 | MultiDimensionalArray(1, 0) = 3 234 | MultiDimensionalArray(1, 1) = 4 235 | JsonString = JsonConverter.ConvertToJson(MultiDimensionalArray) 236 | .Expect(JsonString).ToEqual "[[1,2],[3,4]]" 237 | End With 238 | 239 | With Specs.It("should handle strongly typed arrays") 240 | Dim LongArray(3) As Long 241 | LongArray(0) = 1 242 | LongArray(1) = 2 243 | LongArray(2) = 3 244 | LongArray(3) = 4 245 | 246 | JsonString = JsonConverter.ConvertToJson(LongArray) 247 | .Expect(JsonString).ToEqual "[1,2,3,4]" 248 | 249 | Dim StringArray(3) As String 250 | StringArray(0) = "A" 251 | StringArray(1) = "B" 252 | StringArray(2) = "C" 253 | StringArray(3) = "D" 254 | 255 | JsonString = JsonConverter.ConvertToJson(StringArray) 256 | .Expect(JsonString).ToEqual "[""A"",""B"",""C"",""D""]" 257 | End With 258 | 259 | With Specs.It("should json-encode strings") 260 | Dim Strings As Variant 261 | Strings = Array("""\" & vbCr & vbLf & vbTab & vbBack & vbFormFeed, ChrW(128) & ChrW(32767), "#$%&{|}~") 262 | 263 | JsonString = JsonConverter.ConvertToJson(Strings) 264 | .Expect(JsonString).ToEqual "[""\""\\\r\n\t\b\f"",""\u0080\u7FFF"",""#$%&{|}~""]" 265 | End With 266 | 267 | With Specs.It("should escape solidus with option") 268 | Strings = Array("a/b") 269 | 270 | JsonString = JsonConverter.ConvertToJson(Strings) 271 | .Expect(JsonString).ToEqual "[""a/b""]" 272 | 273 | JsonConverter.JsonOptions.EscapeSolidus = True 274 | JsonString = JsonConverter.ConvertToJson(Strings) 275 | .Expect(JsonString).ToEqual "[""a\/b""]" 276 | JsonConverter.JsonOptions.EscapeSolidus = False 277 | End With 278 | 279 | With Specs.It("should handle Empty and Nothing in arrays as null") 280 | JsonString = JsonConverter.ConvertToJson(Array("a", EmptyVariant, NothingObject, Empty, Nothing, "z")) 281 | .Expect(JsonString).ToEqual "[""a"",null,null,null,null,""z""]" 282 | 283 | Set JsonObject = New Collection 284 | JsonObject.Add "a" 285 | JsonObject.Add EmptyVariant 286 | JsonObject.Add NothingObject 287 | JsonObject.Add Empty 288 | JsonObject.Add Nothing 289 | JsonObject.Add "" 290 | JsonObject.Add "z" 291 | 292 | JsonString = JsonConverter.ConvertToJson(JsonObject) 293 | .Expect(JsonString).ToEqual "[""a"",null,null,null,null,"""",""z""]" 294 | End With 295 | 296 | With Specs.It("should handle Empty and Nothing in objects as undefined") 297 | Set JsonObject = New Dictionary 298 | JsonObject.Add "a", "a" 299 | JsonObject.Add "b", EmptyVariant 300 | JsonObject.Add "c", NothingObject 301 | JsonObject.Add "d", Empty 302 | JsonObject.Add "e", Nothing 303 | JsonObject.Add "f", "" 304 | JsonObject.Add "z", "z" 305 | 306 | JsonString = JsonConverter.ConvertToJson(JsonObject) 307 | .Expect(JsonString).ToEqual "{""a"":""a"",""f"":"""",""z"":""z""}" 308 | End With 309 | 310 | With Specs.It("should use whitespace number/string") 311 | ' Nested, plain array + 2 312 | JsonString = JsonConverter.ConvertToJson(Array(1, Array(2, Array(3))), 2) 313 | .Expect(JsonString).ToEqual _ 314 | "[" & vbNewLine & _ 315 | " 1," & vbNewLine & _ 316 | " [" & vbNewLine & _ 317 | " 2," & vbNewLine & _ 318 | " [" & vbNewLine & _ 319 | " 3" & vbNewLine & _ 320 | " ]" & vbNewLine & _ 321 | " ]" & vbNewLine & _ 322 | "]" 323 | 324 | ' Nested Dictionary + Tab 325 | Set JsonObject = New Dictionary 326 | JsonObject.Add "a", Array(1, 2, 3) 327 | JsonObject.Add "b", "c" 328 | Set NestedObject = New Dictionary 329 | NestedObject.Add "d", "e" 330 | JsonObject.Add "nested", NestedObject 331 | 332 | JsonString = JsonConverter.ConvertToJson(JsonObject, VBA.vbTab) 333 | .Expect(JsonString).ToEqual _ 334 | "{" & vbNewLine & _ 335 | vbTab & """a"": [" & vbNewLine & _ 336 | vbTab & vbTab & "1," & vbNewLine & _ 337 | vbTab & vbTab & "2," & vbNewLine & _ 338 | vbTab & vbTab & "3" & vbNewLine & _ 339 | vbTab & "]," & vbNewLine & _ 340 | vbTab & """b"": ""c""," & vbNewLine & _ 341 | vbTab & """nested"": {" & vbNewLine & _ 342 | vbTab & vbTab & """d"": ""e""" & vbNewLine & _ 343 | vbTab & "}" & vbNewLine & _ 344 | "}" 345 | 346 | ' Multi-dimensional array + 4 347 | MultiDimensionalArray(0, 0) = 1 348 | MultiDimensionalArray(0, 1) = 2 349 | MultiDimensionalArray(1, 0) = Array(1, 2, 3) 350 | MultiDimensionalArray(1, 1) = 4 351 | JsonString = JsonConverter.ConvertToJson(MultiDimensionalArray, 4) 352 | .Expect(JsonString).ToEqual _ 353 | "[" & vbNewLine & _ 354 | " [" & vbNewLine & _ 355 | " 1," & vbNewLine & _ 356 | " 2" & vbNewLine & _ 357 | " ]," & vbNewLine & _ 358 | " [" & vbNewLine & _ 359 | " [" & vbNewLine & _ 360 | " 1," & vbNewLine & _ 361 | " 2," & vbNewLine & _ 362 | " 3" & vbNewLine & _ 363 | " ]," & vbNewLine & _ 364 | " 4" & vbNewLine & _ 365 | " ]" & vbNewLine & _ 366 | "]" 367 | 368 | ' Collection + "-" 369 | Set JsonObject = New Collection 370 | JsonObject.Add Array(1, 2, 3) 371 | 372 | JsonString = JsonConverter.ConvertToJson(JsonObject, "-") 373 | .Expect(JsonString).ToEqual _ 374 | "[" & vbNewLine & _ 375 | "-[" & vbNewLine & _ 376 | "--1," & vbNewLine & _ 377 | "--2," & vbNewLine & _ 378 | "--3" & vbNewLine & _ 379 | "-]" & vbNewLine & _ 380 | "]" 381 | End With 382 | 383 | ' ============================================= ' 384 | ' Errors 385 | ' ============================================= ' 386 | 387 | With Specs.It("should have descriptive parsing errors") 388 | Err.Clear 389 | JsonString = "Howdy!" 390 | Set JsonObject = JsonConverter.ParseJson(JsonString) 391 | 392 | .Expect.RunMatcher "ToMatchParseError", "to match parse error", _ 393 | "Howdy!", "^", "Expecting '{' or '['" 394 | 395 | Err.Clear 396 | JsonString = "{""abc""}" 397 | Set JsonObject = JsonConverter.ParseJson(JsonString) 398 | 399 | .Expect.RunMatcher "ToMatchParseError", "to match parse error", _ 400 | "{""abc""}", " ^", "Expecting ':'" 401 | 402 | Err.Clear 403 | JsonString = "{""abc"":True}" 404 | Set JsonObject = JsonConverter.ParseJson(JsonString) 405 | 406 | .Expect.RunMatcher "ToMatchParseError", "to match parse error", _ 407 | "{""abc"":True}", " ^", "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['" 408 | 409 | Err.Clear 410 | JsonString = "{""abc"":undefined}" 411 | Set JsonObject = JsonConverter.ParseJson(JsonString) 412 | 413 | .Expect.RunMatcher "ToMatchParseError", "to match parse error", _ 414 | "{""abc"":undefined}", " ^", "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['" 415 | End With 416 | 417 | InlineRunner.RunSuite Specs 418 | End Function 419 | 420 | Public Sub RunSpecs() 421 | DisplayRunner.IdCol = 1 422 | DisplayRunner.DescCol = 1 423 | DisplayRunner.ResultCol = 2 424 | DisplayRunner.OutputStartRow = 4 425 | 426 | DisplayRunner.RunSuite Specs 427 | End Sub 428 | 429 | Public Function ToMatchParseError(Actual As Variant, Args As Variant) As Variant 430 | Dim Partial As String 431 | Dim Arrow As String 432 | Dim Message As String 433 | Dim Description As String 434 | 435 | If UBound(Args) < 2 Then 436 | ToMatchParseError = "Need to pass expected partial, arrow, and message""" 437 | ElseIf Err.Number = 10001 Then 438 | Partial = Args(0) 439 | Arrow = Args(1) 440 | Message = Args(2) 441 | Description = "Error parsing JSON:" & vbNewLine & Partial & vbNewLine & Arrow & vbNewLine & Message 442 | 443 | Dim Parts As Variant 444 | Parts = Split(Err.Description, vbNewLine) 445 | 446 | If Parts(1) <> Partial Then 447 | ToMatchParseError = "Expected " & Parts(1) & " to equal " & Partial 448 | ElseIf Parts(2) <> Arrow Then 449 | ToMatchParseError = "Expected " & Parts(2) & " to equal " & Arrow 450 | ElseIf Parts(3) <> Message Then 451 | ToMatchParseError = "Expected " & Parts(3) & " to equal " & Message 452 | ElseIf Err.Description <> Description Then 453 | ToMatchParseError = "Expected " & Err.Description & " to equal " & Description 454 | Else 455 | ToMatchParseError = True 456 | End If 457 | Else 458 | ToMatchParseError = "Expected error number " & Err.Number & " to be 10001" 459 | End If 460 | End Function 461 | -------------------------------------------------------------------------------- /JsonConverter.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "JsonConverter" 2 | '' 3 | ' VBA-JSON v2.3.1 4 | ' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON 5 | ' 6 | ' JSON Converter for VBA 7 | ' 8 | ' Errors: 9 | ' 10001 - JSON parse error 10 | ' 11 | ' @class JsonConverter 12 | ' @author tim.hall.engr@gmail.com 13 | ' @license MIT (http://www.opensource.org/licenses/mit-license.php) 14 | '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' 15 | ' 16 | ' Based originally on vba-json (with extensive changes) 17 | ' BSD license included below 18 | ' 19 | ' JSONLib, http://code.google.com/p/vba-json/ 20 | ' 21 | ' Copyright (c) 2013, Ryo Yokoyama 22 | ' All rights reserved. 23 | ' 24 | ' Redistribution and use in source and binary forms, with or without 25 | ' modification, are permitted provided that the following conditions are met: 26 | ' * Redistributions of source code must retain the above copyright 27 | ' notice, this list of conditions and the following disclaimer. 28 | ' * Redistributions in binary form must reproduce the above copyright 29 | ' notice, this list of conditions and the following disclaimer in the 30 | ' documentation and/or other materials provided with the distribution. 31 | ' * Neither the name of the nor the 32 | ' names of its contributors may be used to endorse or promote products 33 | ' derived from this software without specific prior written permission. 34 | ' 35 | ' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 36 | ' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 37 | ' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 38 | ' DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY 39 | ' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 40 | ' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 41 | ' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 42 | ' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 43 | ' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 44 | ' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 45 | ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' 46 | Option Explicit 47 | 48 | ' === VBA-UTC Headers 49 | #If Mac Then 50 | 51 | #If VBA7 Then 52 | 53 | ' 64-bit Mac (2016) 54 | Private Declare PtrSafe Function utc_popen Lib "/usr/lib/libc.dylib" Alias "popen" _ 55 | (ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr 56 | Private Declare PtrSafe Function utc_pclose Lib "/usr/lib/libc.dylib" Alias "pclose" _ 57 | (ByVal utc_File As LongPtr) As LongPtr 58 | Private Declare PtrSafe Function utc_fread Lib "/usr/lib/libc.dylib" Alias "fread" _ 59 | (ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr 60 | Private Declare PtrSafe Function utc_feof Lib "/usr/lib/libc.dylib" Alias "feof" _ 61 | (ByVal utc_File As LongPtr) As LongPtr 62 | 63 | #Else 64 | 65 | ' 32-bit Mac 66 | Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _ 67 | (ByVal utc_Command As String, ByVal utc_Mode As String) As Long 68 | Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _ 69 | (ByVal utc_File As Long) As Long 70 | Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _ 71 | (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long 72 | Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _ 73 | (ByVal utc_File As Long) As Long 74 | 75 | #End If 76 | 77 | #ElseIf VBA7 Then 78 | 79 | ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx 80 | ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx 81 | ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx 82 | Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ 83 | (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long 84 | Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ 85 | (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long 86 | Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ 87 | (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long 88 | 89 | #Else 90 | 91 | Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ 92 | (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long 93 | Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ 94 | (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long 95 | Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ 96 | (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long 97 | 98 | #End If 99 | 100 | #If Mac Then 101 | 102 | #If VBA7 Then 103 | Private Type utc_ShellResult 104 | utc_Output As String 105 | utc_ExitCode As LongPtr 106 | End Type 107 | 108 | #Else 109 | 110 | Private Type utc_ShellResult 111 | utc_Output As String 112 | utc_ExitCode As Long 113 | End Type 114 | 115 | #End If 116 | 117 | #Else 118 | 119 | Private Type utc_SYSTEMTIME 120 | utc_wYear As Integer 121 | utc_wMonth As Integer 122 | utc_wDayOfWeek As Integer 123 | utc_wDay As Integer 124 | utc_wHour As Integer 125 | utc_wMinute As Integer 126 | utc_wSecond As Integer 127 | utc_wMilliseconds As Integer 128 | End Type 129 | 130 | Private Type utc_TIME_ZONE_INFORMATION 131 | utc_Bias As Long 132 | utc_StandardName(0 To 31) As Integer 133 | utc_StandardDate As utc_SYSTEMTIME 134 | utc_StandardBias As Long 135 | utc_DaylightName(0 To 31) As Integer 136 | utc_DaylightDate As utc_SYSTEMTIME 137 | utc_DaylightBias As Long 138 | End Type 139 | 140 | #End If 141 | ' === End VBA-UTC 142 | 143 | Private Type json_Options 144 | ' VBA only stores 15 significant digits, so any numbers larger than that are truncated 145 | ' 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 146 | ' See: http://support.microsoft.com/kb/269370 147 | ' 148 | ' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits 149 | ' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True` 150 | UseDoubleForLargeNumbers As Boolean 151 | 152 | ' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys 153 | AllowUnquotedKeys As Boolean 154 | 155 | ' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson 156 | EscapeSolidus As Boolean 157 | End Type 158 | Public JsonOptions As json_Options 159 | 160 | ' ============================================= ' 161 | ' Public Methods 162 | ' ============================================= ' 163 | 164 | '' 165 | ' Convert JSON string to object (Dictionary/Collection) 166 | ' 167 | ' @method ParseJson 168 | ' @param {String} json_String 169 | ' @return {Object} (Dictionary or Collection) 170 | ' @throws 10001 - JSON parse error 171 | '' 172 | Public Function ParseJson(ByVal JsonString As String) As Object 173 | Dim json_Index As Long 174 | json_Index = 1 175 | 176 | ' Remove vbCr, vbLf, and vbTab from json_String 177 | JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "") 178 | 179 | json_SkipSpaces JsonString, json_Index 180 | Select Case VBA.Mid$(JsonString, json_Index, 1) 181 | Case "{" 182 | Set ParseJson = json_ParseObject(JsonString, json_Index) 183 | Case "[" 184 | Set ParseJson = json_ParseArray(JsonString, json_Index) 185 | Case Else 186 | ' Error: Invalid JSON string 187 | Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['") 188 | End Select 189 | End Function 190 | 191 | '' 192 | ' Convert object (Dictionary/Collection/Array) to JSON 193 | ' 194 | ' @method ConvertToJson 195 | ' @param {Variant} JsonValue (Dictionary, Collection, or Array) 196 | ' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string 197 | ' @return {String} 198 | '' 199 | Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String 200 | Dim json_Buffer As String 201 | Dim json_BufferPosition As Long 202 | Dim json_BufferLength As Long 203 | Dim json_Index As Long 204 | Dim json_LBound As Long 205 | Dim json_UBound As Long 206 | Dim json_IsFirstItem As Boolean 207 | Dim json_Index2D As Long 208 | Dim json_LBound2D As Long 209 | Dim json_UBound2D As Long 210 | Dim json_IsFirstItem2D As Boolean 211 | Dim json_Key As Variant 212 | Dim json_Value As Variant 213 | Dim json_DateStr As String 214 | Dim json_Converted As String 215 | Dim json_SkipItem As Boolean 216 | Dim json_PrettyPrint As Boolean 217 | Dim json_Indentation As String 218 | Dim json_InnerIndentation As String 219 | 220 | json_LBound = -1 221 | json_UBound = -1 222 | json_IsFirstItem = True 223 | json_LBound2D = -1 224 | json_UBound2D = -1 225 | json_IsFirstItem2D = True 226 | json_PrettyPrint = Not IsMissing(Whitespace) 227 | 228 | Select Case VBA.VarType(JsonValue) 229 | Case VBA.vbNull 230 | ConvertToJson = "null" 231 | Case VBA.vbDate 232 | ' Date 233 | json_DateStr = ConvertToIso(VBA.CDate(JsonValue)) 234 | 235 | ConvertToJson = """" & json_DateStr & """" 236 | Case VBA.vbString 237 | ' String (or large number encoded as string) 238 | If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then 239 | ConvertToJson = JsonValue 240 | Else 241 | ConvertToJson = """" & json_Encode(JsonValue) & """" 242 | End If 243 | Case VBA.vbBoolean 244 | If JsonValue Then 245 | ConvertToJson = "true" 246 | Else 247 | ConvertToJson = "false" 248 | End If 249 | Case VBA.vbArray To VBA.vbArray + VBA.vbByte 250 | If json_PrettyPrint Then 251 | If VBA.VarType(Whitespace) = VBA.vbString Then 252 | json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) 253 | json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace) 254 | Else 255 | json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) 256 | json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace) 257 | End If 258 | End If 259 | 260 | ' Array 261 | json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength 262 | 263 | On Error Resume Next 264 | 265 | json_LBound = LBound(JsonValue, 1) 266 | json_UBound = UBound(JsonValue, 1) 267 | json_LBound2D = LBound(JsonValue, 2) 268 | json_UBound2D = UBound(JsonValue, 2) 269 | 270 | If json_LBound >= 0 And json_UBound >= 0 Then 271 | For json_Index = json_LBound To json_UBound 272 | If json_IsFirstItem Then 273 | json_IsFirstItem = False 274 | Else 275 | ' Append comma to previous line 276 | json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength 277 | End If 278 | 279 | If json_LBound2D >= 0 And json_UBound2D >= 0 Then 280 | ' 2D Array 281 | If json_PrettyPrint Then 282 | json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength 283 | End If 284 | json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength 285 | 286 | For json_Index2D = json_LBound2D To json_UBound2D 287 | If json_IsFirstItem2D Then 288 | json_IsFirstItem2D = False 289 | Else 290 | json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength 291 | End If 292 | 293 | json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) 294 | 295 | ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null 296 | If json_Converted = "" Then 297 | ' (nest to only check if converted = "") 298 | If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then 299 | json_Converted = "null" 300 | End If 301 | End If 302 | 303 | If json_PrettyPrint Then 304 | json_Converted = vbNewLine & json_InnerIndentation & json_Converted 305 | End If 306 | 307 | json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength 308 | Next json_Index2D 309 | 310 | If json_PrettyPrint Then 311 | json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength 312 | End If 313 | 314 | json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength 315 | json_IsFirstItem2D = True 316 | Else 317 | ' 1D Array 318 | json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1) 319 | 320 | ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null 321 | If json_Converted = "" Then 322 | ' (nest to only check if converted = "") 323 | If json_IsUndefined(JsonValue(json_Index)) Then 324 | json_Converted = "null" 325 | End If 326 | End If 327 | 328 | If json_PrettyPrint Then 329 | json_Converted = vbNewLine & json_Indentation & json_Converted 330 | End If 331 | 332 | json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength 333 | End If 334 | Next json_Index 335 | End If 336 | 337 | On Error GoTo 0 338 | 339 | If json_PrettyPrint Then 340 | json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength 341 | 342 | If VBA.VarType(Whitespace) = VBA.vbString Then 343 | json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) 344 | Else 345 | json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) 346 | End If 347 | End If 348 | 349 | json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength 350 | 351 | ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) 352 | 353 | ' Dictionary or Collection 354 | Case VBA.vbObject 355 | If json_PrettyPrint Then 356 | If VBA.VarType(Whitespace) = VBA.vbString Then 357 | json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) 358 | Else 359 | json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) 360 | End If 361 | End If 362 | 363 | ' Dictionary 364 | If VBA.TypeName(JsonValue) = "Dictionary" Then 365 | json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength 366 | For Each json_Key In JsonValue.Keys 367 | ' For Objects, undefined (Empty/Nothing) is not added to object 368 | json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1) 369 | If json_Converted = "" Then 370 | json_SkipItem = json_IsUndefined(JsonValue(json_Key)) 371 | Else 372 | json_SkipItem = False 373 | End If 374 | 375 | If Not json_SkipItem Then 376 | If json_IsFirstItem Then 377 | json_IsFirstItem = False 378 | Else 379 | json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength 380 | End If 381 | 382 | If json_PrettyPrint Then 383 | json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted 384 | Else 385 | json_Converted = """" & json_Key & """:" & json_Converted 386 | End If 387 | 388 | json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength 389 | End If 390 | Next json_Key 391 | 392 | If json_PrettyPrint Then 393 | json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength 394 | 395 | If VBA.VarType(Whitespace) = VBA.vbString Then 396 | json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) 397 | Else 398 | json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) 399 | End If 400 | End If 401 | 402 | json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength 403 | 404 | ' Collection 405 | ElseIf VBA.TypeName(JsonValue) = "Collection" Then 406 | json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength 407 | For Each json_Value In JsonValue 408 | If json_IsFirstItem Then 409 | json_IsFirstItem = False 410 | Else 411 | json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength 412 | End If 413 | 414 | json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) 415 | 416 | ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null 417 | If json_Converted = "" Then 418 | ' (nest to only check if converted = "") 419 | If json_IsUndefined(json_Value) Then 420 | json_Converted = "null" 421 | End If 422 | End If 423 | 424 | If json_PrettyPrint Then 425 | json_Converted = vbNewLine & json_Indentation & json_Converted 426 | End If 427 | 428 | json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength 429 | Next json_Value 430 | 431 | If json_PrettyPrint Then 432 | json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength 433 | 434 | If VBA.VarType(Whitespace) = VBA.vbString Then 435 | json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) 436 | Else 437 | json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) 438 | End If 439 | End If 440 | 441 | json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength 442 | End If 443 | 444 | ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) 445 | Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal 446 | ' Number (use decimals for numbers) 447 | ConvertToJson = VBA.Replace(JsonValue, ",", ".") 448 | Case Else 449 | ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType 450 | ' Use VBA's built-in to-string 451 | On Error Resume Next 452 | ConvertToJson = JsonValue 453 | On Error GoTo 0 454 | End Select 455 | End Function 456 | 457 | ' ============================================= ' 458 | ' Private Functions 459 | ' ============================================= ' 460 | 461 | Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary 462 | Dim json_Key As String 463 | Dim json_NextChar As String 464 | 465 | Set json_ParseObject = New Dictionary 466 | json_SkipSpaces json_String, json_Index 467 | If VBA.Mid$(json_String, json_Index, 1) <> "{" Then 468 | Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'") 469 | Else 470 | json_Index = json_Index + 1 471 | 472 | Do 473 | json_SkipSpaces json_String, json_Index 474 | If VBA.Mid$(json_String, json_Index, 1) = "}" Then 475 | json_Index = json_Index + 1 476 | Exit Function 477 | ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then 478 | json_Index = json_Index + 1 479 | json_SkipSpaces json_String, json_Index 480 | End If 481 | 482 | json_Key = json_ParseKey(json_String, json_Index) 483 | json_NextChar = json_Peek(json_String, json_Index) 484 | If json_NextChar = "[" Or json_NextChar = "{" Then 485 | Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) 486 | Else 487 | json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) 488 | End If 489 | Loop 490 | End If 491 | End Function 492 | 493 | Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection 494 | Set json_ParseArray = New Collection 495 | 496 | json_SkipSpaces json_String, json_Index 497 | If VBA.Mid$(json_String, json_Index, 1) <> "[" Then 498 | Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['") 499 | Else 500 | json_Index = json_Index + 1 501 | 502 | Do 503 | json_SkipSpaces json_String, json_Index 504 | If VBA.Mid$(json_String, json_Index, 1) = "]" Then 505 | json_Index = json_Index + 1 506 | Exit Function 507 | ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then 508 | json_Index = json_Index + 1 509 | json_SkipSpaces json_String, json_Index 510 | End If 511 | 512 | json_ParseArray.Add json_ParseValue(json_String, json_Index) 513 | Loop 514 | End If 515 | End Function 516 | 517 | Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant 518 | json_SkipSpaces json_String, json_Index 519 | Select Case VBA.Mid$(json_String, json_Index, 1) 520 | Case "{" 521 | Set json_ParseValue = json_ParseObject(json_String, json_Index) 522 | Case "[" 523 | Set json_ParseValue = json_ParseArray(json_String, json_Index) 524 | Case """", "'" 525 | json_ParseValue = json_ParseString(json_String, json_Index) 526 | Case Else 527 | If VBA.Mid$(json_String, json_Index, 4) = "true" Then 528 | json_ParseValue = True 529 | json_Index = json_Index + 4 530 | ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then 531 | json_ParseValue = False 532 | json_Index = json_Index + 5 533 | ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then 534 | json_ParseValue = Null 535 | json_Index = json_Index + 4 536 | ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then 537 | json_ParseValue = json_ParseNumber(json_String, json_Index) 538 | Else 539 | Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['") 540 | End If 541 | End Select 542 | End Function 543 | 544 | Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String 545 | Dim json_Quote As String 546 | Dim json_Char As String 547 | Dim json_Code As String 548 | Dim json_Buffer As String 549 | Dim json_BufferPosition As Long 550 | Dim json_BufferLength As Long 551 | 552 | json_SkipSpaces json_String, json_Index 553 | 554 | ' Store opening quote to look for matching closing quote 555 | json_Quote = VBA.Mid$(json_String, json_Index, 1) 556 | json_Index = json_Index + 1 557 | 558 | Do While json_Index > 0 And json_Index <= Len(json_String) 559 | json_Char = VBA.Mid$(json_String, json_Index, 1) 560 | 561 | Select Case json_Char 562 | Case "\" 563 | ' Escaped string, \\, or \/ 564 | json_Index = json_Index + 1 565 | json_Char = VBA.Mid$(json_String, json_Index, 1) 566 | 567 | Select Case json_Char 568 | Case """", "\", "/", "'" 569 | json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength 570 | json_Index = json_Index + 1 571 | Case "b" 572 | json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength 573 | json_Index = json_Index + 1 574 | Case "f" 575 | json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength 576 | json_Index = json_Index + 1 577 | Case "n" 578 | json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength 579 | json_Index = json_Index + 1 580 | Case "r" 581 | json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength 582 | json_Index = json_Index + 1 583 | Case "t" 584 | json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength 585 | json_Index = json_Index + 1 586 | Case "u" 587 | ' Unicode character escape (e.g. \u00a9 = Copyright) 588 | json_Index = json_Index + 1 589 | json_Code = VBA.Mid$(json_String, json_Index, 4) 590 | json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength 591 | json_Index = json_Index + 4 592 | End Select 593 | Case json_Quote 594 | json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition) 595 | json_Index = json_Index + 1 596 | Exit Function 597 | Case Else 598 | json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength 599 | json_Index = json_Index + 1 600 | End Select 601 | Loop 602 | End Function 603 | 604 | Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant 605 | Dim json_Char As String 606 | Dim json_Value As String 607 | Dim json_IsLargeNumber As Boolean 608 | 609 | json_SkipSpaces json_String, json_Index 610 | 611 | Do While json_Index > 0 And json_Index <= Len(json_String) 612 | json_Char = VBA.Mid$(json_String, json_Index, 1) 613 | 614 | If VBA.InStr("+-0123456789.eE", json_Char) Then 615 | ' Unlikely to have massive number, so use simple append rather than buffer here 616 | json_Value = json_Value & json_Char 617 | json_Index = json_Index + 1 618 | Else 619 | ' Excel only stores 15 significant digits, so any numbers larger than that are truncated 620 | ' 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 621 | ' See: http://support.microsoft.com/kb/269370 622 | ' 623 | ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number 624 | ' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16) 625 | json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16) 626 | If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then 627 | json_ParseNumber = json_Value 628 | Else 629 | ' VBA.Val does not use regional settings, so guard for comma is not needed 630 | json_ParseNumber = VBA.Val(json_Value) 631 | End If 632 | Exit Function 633 | End If 634 | Loop 635 | End Function 636 | 637 | Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String 638 | ' Parse key with single or double quotes 639 | If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then 640 | json_ParseKey = json_ParseString(json_String, json_Index) 641 | ElseIf JsonOptions.AllowUnquotedKeys Then 642 | Dim json_Char As String 643 | Do While json_Index > 0 And json_Index <= Len(json_String) 644 | json_Char = VBA.Mid$(json_String, json_Index, 1) 645 | If (json_Char <> " ") And (json_Char <> ":") Then 646 | json_ParseKey = json_ParseKey & json_Char 647 | json_Index = json_Index + 1 648 | Else 649 | Exit Do 650 | End If 651 | Loop 652 | Else 653 | Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''") 654 | End If 655 | 656 | ' Check for colon and skip if present or throw if not present 657 | json_SkipSpaces json_String, json_Index 658 | If VBA.Mid$(json_String, json_Index, 1) <> ":" Then 659 | Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'") 660 | Else 661 | json_Index = json_Index + 1 662 | End If 663 | End Function 664 | 665 | Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean 666 | ' Empty / Nothing -> undefined 667 | Select Case VBA.VarType(json_Value) 668 | Case VBA.vbEmpty 669 | json_IsUndefined = True 670 | Case VBA.vbObject 671 | Select Case VBA.TypeName(json_Value) 672 | Case "Empty", "Nothing" 673 | json_IsUndefined = True 674 | End Select 675 | End Select 676 | End Function 677 | 678 | Private Function json_Encode(ByVal json_Text As Variant) As String 679 | ' Reference: http://www.ietf.org/rfc/rfc4627.txt 680 | ' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab 681 | Dim json_Index As Long 682 | Dim json_Char As String 683 | Dim json_AscCode As Long 684 | Dim json_Buffer As String 685 | Dim json_BufferPosition As Long 686 | Dim json_BufferLength As Long 687 | 688 | For json_Index = 1 To VBA.Len(json_Text) 689 | json_Char = VBA.Mid$(json_Text, json_Index, 1) 690 | json_AscCode = VBA.AscW(json_Char) 691 | 692 | ' When AscW returns a negative number, it returns the twos complement form of that number. 693 | ' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result. 694 | ' https://support.microsoft.com/en-us/kb/272138 695 | If json_AscCode < 0 Then 696 | json_AscCode = json_AscCode + 65536 697 | End If 698 | 699 | ' From spec, ", \, and control characters must be escaped (solidus is optional) 700 | 701 | Select Case json_AscCode 702 | Case 34 703 | ' " -> 34 -> \" 704 | json_Char = "\""" 705 | Case 92 706 | ' \ -> 92 -> \\ 707 | json_Char = "\\" 708 | Case 47 709 | ' / -> 47 -> \/ (optional) 710 | If JsonOptions.EscapeSolidus Then 711 | json_Char = "\/" 712 | End If 713 | Case 8 714 | ' backspace -> 8 -> \b 715 | json_Char = "\b" 716 | Case 12 717 | ' form feed -> 12 -> \f 718 | json_Char = "\f" 719 | Case 10 720 | ' line feed -> 10 -> \n 721 | json_Char = "\n" 722 | Case 13 723 | ' carriage return -> 13 -> \r 724 | json_Char = "\r" 725 | Case 9 726 | ' tab -> 9 -> \t 727 | json_Char = "\t" 728 | Case 0 To 31, 127 To 65535 729 | ' Non-ascii characters -> convert to 4-digit hex 730 | json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4) 731 | End Select 732 | 733 | json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength 734 | Next json_Index 735 | 736 | json_Encode = json_BufferToString(json_Buffer, json_BufferPosition) 737 | End Function 738 | 739 | Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String 740 | ' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef) 741 | json_SkipSpaces json_String, json_Index 742 | json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters) 743 | End Function 744 | 745 | Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long) 746 | ' Increment index to skip over spaces 747 | Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " " 748 | json_Index = json_Index + 1 749 | Loop 750 | End Sub 751 | 752 | Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean 753 | ' Check if the given string is considered a "large number" 754 | ' (See json_ParseNumber) 755 | 756 | Dim json_Length As Long 757 | Dim json_CharIndex As Long 758 | json_Length = VBA.Len(json_String) 759 | 760 | ' Length with be at least 16 characters and assume will be less than 100 characters 761 | If json_Length >= 16 And json_Length <= 100 Then 762 | Dim json_CharCode As String 763 | 764 | json_StringIsLargeNumber = True 765 | 766 | For json_CharIndex = 1 To json_Length 767 | json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1)) 768 | Select Case json_CharCode 769 | ' Look for .|0-9|E|e 770 | Case 46, 48 To 57, 69, 101 771 | ' Continue through characters 772 | Case Else 773 | json_StringIsLargeNumber = False 774 | Exit Function 775 | End Select 776 | Next json_CharIndex 777 | End If 778 | End Function 779 | 780 | Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, ErrorMessage As String) 781 | ' Provide detailed parse error message, including details of where and what occurred 782 | ' 783 | ' Example: 784 | ' Error parsing JSON: 785 | ' {"abcde":True} 786 | ' ^ 787 | ' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '[' 788 | 789 | Dim json_StartIndex As Long 790 | Dim json_StopIndex As Long 791 | 792 | ' Include 10 characters before and after error (if possible) 793 | json_StartIndex = json_Index - 10 794 | json_StopIndex = json_Index + 10 795 | If json_StartIndex <= 0 Then 796 | json_StartIndex = 1 797 | End If 798 | If json_StopIndex > VBA.Len(json_String) Then 799 | json_StopIndex = VBA.Len(json_String) 800 | End If 801 | 802 | json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _ 803 | VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _ 804 | VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _ 805 | ErrorMessage 806 | End Function 807 | 808 | Private Sub json_BufferAppend(ByRef json_Buffer As String, _ 809 | ByRef json_Append As Variant, _ 810 | ByRef json_BufferPosition As Long, _ 811 | ByRef json_BufferLength As Long) 812 | ' VBA can be slow to append strings due to allocating a new string for each append 813 | ' Instead of using the traditional append, allocate a large empty string and then copy string at append position 814 | ' 815 | ' Example: 816 | ' Buffer: "abc " 817 | ' Append: "def" 818 | ' Buffer Position: 3 819 | ' Buffer Length: 5 820 | ' 821 | ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer 822 | ' Buffer: "abc " 823 | ' Buffer Length: 10 824 | ' 825 | ' Put "def" into buffer at position 3 (0-based) 826 | ' Buffer: "abcdef " 827 | ' 828 | ' Approach based on cStringBuilder from vbAccelerator 829 | ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp 830 | ' 831 | ' and clsStringAppend from Philip Swannell 832 | ' https://github.com/VBA-tools/VBA-JSON/pull/82 833 | 834 | Dim json_AppendLength As Long 835 | Dim json_LengthPlusPosition As Long 836 | 837 | json_AppendLength = VBA.Len(json_Append) 838 | json_LengthPlusPosition = json_AppendLength + json_BufferPosition 839 | 840 | If json_LengthPlusPosition > json_BufferLength Then 841 | ' Appending would overflow buffer, add chunk 842 | ' (double buffer length or append length, whichever is bigger) 843 | Dim json_AddedLength As Long 844 | json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength) 845 | 846 | json_Buffer = json_Buffer & VBA.Space$(json_AddedLength) 847 | json_BufferLength = json_BufferLength + json_AddedLength 848 | End If 849 | 850 | ' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error: 851 | ' Function call on left-hand side of assignment must return Variant or Object 852 | Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append) 853 | json_BufferPosition = json_BufferPosition + json_AppendLength 854 | End Sub 855 | 856 | Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String 857 | If json_BufferPosition > 0 Then 858 | json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition) 859 | End If 860 | End Function 861 | 862 | '' 863 | ' VBA-UTC v1.0.6 864 | ' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter 865 | ' 866 | ' UTC/ISO 8601 Converter for VBA 867 | ' 868 | ' Errors: 869 | ' 10011 - UTC parsing error 870 | ' 10012 - UTC conversion error 871 | ' 10013 - ISO 8601 parsing error 872 | ' 10014 - ISO 8601 conversion error 873 | ' 874 | ' @module UtcConverter 875 | ' @author tim.hall.engr@gmail.com 876 | ' @license MIT (http://www.opensource.org/licenses/mit-license.php) 877 | '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' 878 | 879 | ' (Declarations moved to top) 880 | 881 | ' ============================================= ' 882 | ' Public Methods 883 | ' ============================================= ' 884 | 885 | '' 886 | ' Parse UTC date to local date 887 | ' 888 | ' @method ParseUtc 889 | ' @param {Date} UtcDate 890 | ' @return {Date} Local date 891 | ' @throws 10011 - UTC parsing error 892 | '' 893 | Public Function ParseUtc(utc_UtcDate As Date) As Date 894 | On Error GoTo utc_ErrorHandling 895 | 896 | #If Mac Then 897 | ParseUtc = utc_ConvertDate(utc_UtcDate) 898 | #Else 899 | Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION 900 | Dim utc_LocalDate As utc_SYSTEMTIME 901 | 902 | utc_GetTimeZoneInformation utc_TimeZoneInfo 903 | utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate 904 | 905 | ParseUtc = utc_SystemTimeToDate(utc_LocalDate) 906 | #End If 907 | 908 | Exit Function 909 | 910 | utc_ErrorHandling: 911 | Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description 912 | End Function 913 | 914 | '' 915 | ' Convert local date to UTC date 916 | ' 917 | ' @method ConvertToUrc 918 | ' @param {Date} utc_LocalDate 919 | ' @return {Date} UTC date 920 | ' @throws 10012 - UTC conversion error 921 | '' 922 | Public Function ConvertToUtc(utc_LocalDate As Date) As Date 923 | On Error GoTo utc_ErrorHandling 924 | 925 | #If Mac Then 926 | ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True) 927 | #Else 928 | Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION 929 | Dim utc_UtcDate As utc_SYSTEMTIME 930 | 931 | utc_GetTimeZoneInformation utc_TimeZoneInfo 932 | utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate 933 | 934 | ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate) 935 | #End If 936 | 937 | Exit Function 938 | 939 | utc_ErrorHandling: 940 | Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description 941 | End Function 942 | 943 | '' 944 | ' Parse ISO 8601 date string to local date 945 | ' 946 | ' @method ParseIso 947 | ' @param {Date} utc_IsoString 948 | ' @return {Date} Local date 949 | ' @throws 10013 - ISO 8601 parsing error 950 | '' 951 | Public Function ParseIso(utc_IsoString As String) As Date 952 | On Error GoTo utc_ErrorHandling 953 | 954 | Dim utc_Parts() As String 955 | Dim utc_DateParts() As String 956 | Dim utc_TimeParts() As String 957 | Dim utc_OffsetIndex As Long 958 | Dim utc_HasOffset As Boolean 959 | Dim utc_NegativeOffset As Boolean 960 | Dim utc_OffsetParts() As String 961 | Dim utc_Offset As Date 962 | 963 | utc_Parts = VBA.Split(utc_IsoString, "T") 964 | utc_DateParts = VBA.Split(utc_Parts(0), "-") 965 | ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2))) 966 | 967 | If UBound(utc_Parts) > 0 Then 968 | If VBA.InStr(utc_Parts(1), "Z") Then 969 | utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":") 970 | Else 971 | utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+") 972 | If utc_OffsetIndex = 0 Then 973 | utc_NegativeOffset = True 974 | utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-") 975 | End If 976 | 977 | If utc_OffsetIndex > 0 Then 978 | utc_HasOffset = True 979 | utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":") 980 | utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":") 981 | 982 | Select Case UBound(utc_OffsetParts) 983 | Case 0 984 | utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0) 985 | Case 1 986 | utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0) 987 | Case 2 988 | ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues 989 | utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2)))) 990 | End Select 991 | 992 | If utc_NegativeOffset Then: utc_Offset = -utc_Offset 993 | Else 994 | utc_TimeParts = VBA.Split(utc_Parts(1), ":") 995 | End If 996 | End If 997 | 998 | Select Case UBound(utc_TimeParts) 999 | Case 0 1000 | ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0) 1001 | Case 1 1002 | ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0) 1003 | Case 2 1004 | ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues 1005 | ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2)))) 1006 | End Select 1007 | 1008 | ParseIso = ParseUtc(ParseIso) 1009 | 1010 | If utc_HasOffset Then 1011 | ParseIso = ParseIso - utc_Offset 1012 | End If 1013 | End If 1014 | 1015 | Exit Function 1016 | 1017 | utc_ErrorHandling: 1018 | Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description 1019 | End Function 1020 | 1021 | '' 1022 | ' Convert local date to ISO 8601 string 1023 | ' 1024 | ' @method ConvertToIso 1025 | ' @param {Date} utc_LocalDate 1026 | ' @return {Date} ISO 8601 string 1027 | ' @throws 10014 - ISO 8601 conversion error 1028 | '' 1029 | Public Function ConvertToIso(utc_LocalDate As Date) As String 1030 | On Error GoTo utc_ErrorHandling 1031 | 1032 | ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z") 1033 | 1034 | Exit Function 1035 | 1036 | utc_ErrorHandling: 1037 | Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description 1038 | End Function 1039 | 1040 | ' ============================================= ' 1041 | ' Private Functions 1042 | ' ============================================= ' 1043 | 1044 | #If Mac Then 1045 | 1046 | Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date 1047 | Dim utc_ShellCommand As String 1048 | Dim utc_Result As utc_ShellResult 1049 | Dim utc_Parts() As String 1050 | Dim utc_DateParts() As String 1051 | Dim utc_TimeParts() As String 1052 | 1053 | If utc_ConvertToUtc Then 1054 | utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _ 1055 | "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _ 1056 | " +'%s'` +'%Y-%m-%d %H:%M:%S'" 1057 | Else 1058 | utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _ 1059 | "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _ 1060 | "+'%Y-%m-%d %H:%M:%S'" 1061 | End If 1062 | 1063 | utc_Result = utc_ExecuteInShell(utc_ShellCommand) 1064 | 1065 | If utc_Result.utc_Output = "" Then 1066 | Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed" 1067 | Else 1068 | utc_Parts = Split(utc_Result.utc_Output, " ") 1069 | utc_DateParts = Split(utc_Parts(0), "-") 1070 | utc_TimeParts = Split(utc_Parts(1), ":") 1071 | 1072 | utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _ 1073 | TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2)) 1074 | End If 1075 | End Function 1076 | 1077 | Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult 1078 | #If VBA7 Then 1079 | Dim utc_File As LongPtr 1080 | Dim utc_Read As LongPtr 1081 | #Else 1082 | Dim utc_File As Long 1083 | Dim utc_Read As Long 1084 | #End If 1085 | 1086 | Dim utc_Chunk As String 1087 | 1088 | On Error GoTo utc_ErrorHandling 1089 | utc_File = utc_popen(utc_ShellCommand, "r") 1090 | 1091 | If utc_File = 0 Then: Exit Function 1092 | 1093 | Do While utc_feof(utc_File) = 0 1094 | utc_Chunk = VBA.Space$(50) 1095 | utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File)) 1096 | If utc_Read > 0 Then 1097 | utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read)) 1098 | utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk 1099 | End If 1100 | Loop 1101 | 1102 | utc_ErrorHandling: 1103 | utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File)) 1104 | End Function 1105 | 1106 | #Else 1107 | 1108 | Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME 1109 | utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value) 1110 | utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value) 1111 | utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value) 1112 | utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value) 1113 | utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value) 1114 | utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value) 1115 | utc_DateToSystemTime.utc_wMilliseconds = 0 1116 | End Function 1117 | 1118 | Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date 1119 | utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _ 1120 | TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond) 1121 | End Function 1122 | 1123 | #End If 1124 | --------------------------------------------------------------------------------