Advertisement
F0u4d

VBA Json Converter

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