actorcat

Crypto Prices

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