diff --git a/GetAvalibleQuerys.bas b/GetAvalibleQuerys.bas new file mode 100644 index 0000000..423449f --- /dev/null +++ b/GetAvalibleQuerys.bas @@ -0,0 +1,140 @@ +Attribute VB_Name = "GetAvalibleQuerys" +Sub queryAvi() + + On Error GoTo ErrorHandler ' Enable error handling + + Dim req As New WinHttpRequest + Dim reqUrl As String + Dim plantSelect As String + Dim staticData As Worksheet + Dim jsonResponse As String + Dim json As Object + Dim sheetVersion As Object + Dim server As String + + + 'where is our plant data to match too? + Dim plantData As Range + Set plantData = Sheet2.Range("A1:B30") + + ' clear the data if any is there + 'Sheet1.Range("A8:C8").Clear + + 'get the plant server based on the selection + plantSelect = Sheets("Data").Range("E1").Value + + ' Check if we have a match before moving forward + Dim cell As Range + Dim plantFound As Boolean + + plantFound = False + + For Each cell In plantData + If cell.Value = plantSelect Then + ' Found the server + If cell.Value = "All" Then + 'Debug.Print "all servers were selected" + Exit For + Else + 'Debug.Print "Server that was selected : " & cell.Offset(0, 1).Value + server = cell.Offset(0, 1).Value + Exit For + End If + Exit For + End If + Next cell + + 'if all is selected it will point to the test server. + + If plantSelect = "All" Then + reqUrl = "http://usmcd1vms036:3000/api/datamart/getavalibleaquerys" + Else + ' as iowa pet is on a differnt port we want to grab keep everything the same + If plantSelect = "Iowa ISBM, Iowa" Then + + reqUrl = "http://" & server & ":3001/api/datamart/getavalibleaquerys" + Else + reqUrl = "http://" & server & ":3000/api/datamart/getavalibleaquerys" + End If + End If + + 'double checking the url + Debug.Print "Url to pull the querys form it " & reqUrl + + 'set the static data sheet + Set staticData = Sheet2 + + 'clear the content so its always fresh + staticData.Range("D1:E20").ClearContents + + ' get the data + req.Open "GET", reqUrl, False + + req.Send + + If req.Status <> 200 Then + MsgBox req.Status & " - " & req.StatusText + End If + + + ' Get the response text (JSON) + jsonResponse = req.ResponseText + + ' crtl + g to pull up the debut + + ' Debug print the raw JSON response + ' Debug.Print jsonResponse + + ' Parse the JSON response using JsonConverter + Set json = JsonConverter.ParseJson(jsonResponse) + + + 'Debug.Print json("sheetVersion") + + Set dataArray = json("data") + + ' Set up the headers in the first row just for a reference + Set headerRow = Sheet2.Range("D1") + + + ' Dump the querys into the table so we can use it in our list :) + If json("success") Then + 'add the headers + ' Loop through the first item to get the keys (name, endpoint) + h = 1 + For Each Item In dataArray(1).Keys + ' Debug.Print Item + headerRow.Cells(1, h).Value = Item ' Place the key as a header + h = h + 1 + Next Item + + ' Populate the data below the headers + For j = 1 To dataArray.Count + i = 1 + For Each Item In dataArray(j).Keys + headerRow.Offset(j, i - 1).Value = dataArray(j)(Item) ' Populate data under the headers + i = i + 1 + Next Item + Next j + Else + MsgBox "Error: " & json("message") + End If + + If json("sheetVersion") <> Sheet2.Range("I1").Value Then + MsgBox "There is a new version of the sheet please download the new version to get all the fixes, you do not need to but errors will not be supported on older versions! You can get a new sheet from NOAM logistics > plant mgt files" + Exit Sub + End If + + Exit Sub + +ErrorHandler: + ' Handle specific error for connection issues + If Err.Number = -2147012867 Then + MsgBox "Please make sure you are connected to vpn, and or make sure the server is online.", vbCritical + Else + ' Handle other errors + MsgBox "An unexpected error occurred: " & Err.Description, vbCritical + End If + +End Sub + diff --git a/GetData.bas b/GetData.bas new file mode 100644 index 0000000..31138ec --- /dev/null +++ b/GetData.bas @@ -0,0 +1,228 @@ +Attribute VB_Name = "GetData" +Sub getData() +On Error GoTo ErrorHandler ' Enable error handling + + Dim plantSelect As String + Dim req As New WinHttpRequest + Dim reqUrl As String + Dim cell As Range + Dim plantFound As Boolean + Dim plantData As Range + Dim queryData As Range + Dim server As String + Dim queryToRun As String + Dim ws As Worksheet + Dim lastColumn As Integer + Dim dataRange As Variant + Dim json As Object + Dim dataArray As Object + Dim headerRow As Range + + + + 'where is our plant data to match too? + Set plantData = Sheet2.Range("A1:B30") + Set queryData = Sheet2.Range("D2:E100") + + ' what plant is selected + plantSelect = Sheets("Data").Range("E1").Value + + 'until the all function is created send a message box to check the server + 'If plantSelect = "All" Then + ' MsgBox "The ""All"" function is not fully operational please select a plant to move forward" + ' Exit Sub + 'End If + + 'if we are missing the query we want to warn everyone too + If Sheets("Data").Range("G1").Value = "" Then + MsgBox "Please select a query you want to pull before pressing the ""Get data"" button." + End If + + 'check if the data sheet was removed or changed and recreate it it was changed and then clear the data + On Error Resume Next + Set ws = Sheets("Data") + If ws Is Nothing Then + Set ws = Sheets.Add + ws.Name = "Data" + Else + 'ws.Cells.Clear ' Clear existing data if the sheet already exists + Sheets("Data").Range("A5:BB50000").ClearContents + End If + + On Error GoTo 0 + + 'go back to the setup data sheet maybe :P + Sheets("Data").Select + ' Sheets("Data").Range("A5:BB50000").ClearContents + + ' create the url from the plan + plantFound = False + + For Each cell In plantData + If cell.Value = plantSelect Then + ' Found the server + If cell.Value = "All" Then + Debug.Print "all servers were selected" + Exit For + Else + 'Debug.Print "Server that was selected : " & cell.Offset(0, 1).Value + server = cell.Offset(0, 1).Value + Exit For + End If + Exit For + End If + Next cell + + + 'get the query endpoint + For Each cell In queryData + If cell.Value = Sheets("Data").Range("G1").Value Then + 'Debug.Print "Server that was selected : " & cell.Offset(0, 1).Value + queryToRun = cell.Offset(0, 1).Value + Exit For + End If + Next cell + + ' if the query would have extra parameters add them here + For Each cell In queryData + If cell.Value = Sheets("Data").Range("G1").Value Then + 'Debug.Print "Server that was selected : " & cell.Offset(0, 1).Value + 'queryToRun = queryToRun + cell.Offset(0, 2).Value + + 'add the first part of the additional critiera to the query + If Sheets("Data").Range("D2").Value <> "" Then + If Trim(Sheets("Data").Range("D2").Value) <> "" And Trim(Sheets("Data").Range("D3").Value) <> "" Then + queryToRun = queryToRun & "?" & Sheets("Data").Range("D2").Value & "=" & Sheets("Data").Range("D3").Value + If Sheets("Data").Range("E2").Value <> "" And Sheets("Data").Range("E3").Value <> "" Then + queryToRun = queryToRun & "&" & Sheets("Data").Range("E2").Value & "=" & Sheets("Data").Range("E3").Value + If Sheets("Data").Range("F2").Value <> "" And Sheets("Data").Range("F3").Value <> "" Then + queryToRun = queryToRun & "&" & Sheets("Data").Range("F2").Value & "=" & Sheets("Data").Range("F3").Value + End If + End If + ElseIf Trim(Sheets("Data").Range("E2").Value) <> "" And Trim(Sheets("Data").Range("E3").Value) <> "" Then + queryToRun = queryToRun & "?" & Sheets("Data").Range("E2").Value & "=" & Sheets("Data").Range("E3").Value + End If + End If + Exit For + End If + Next cell + + 'Debug.Print queryToRun + If plantSelect = "All" Then + 'reqUrl = "http://localhost:4000" & queryToRun + getAllPlants queryToRun + Exit Sub + Else + ' as iowa pet is on a differnt port we want to grab keep everything the same + If plantSelect = "Iowa ISBM, Iowa" Then + + reqUrl = "http://" & server & ":3001" & queryToRun + Else + reqUrl = "http://" & server & ":3000" & queryToRun + End If + End If + + Debug.Print reqUrl + + 'url is created get the request going. + req.Open "GET", reqUrl, False + + req.Send + + If req.Status <> 200 Then + MsgBox req.Status & " - " & req.StatusText & " - " & req.ResponseText + Exit Sub + End If + + + ' Get the response text (JSON) + jsonResponse = req.ResponseText + + ' crtl + g to pull up the debut + + ' Debug print the raw JSON response + 'Debug.Print jsonResponse + + Set json = JsonConverter.ParseJson(jsonResponse) + + Set dataArray = json("data") + + 'Debug.Print dataArray + + ' Check if dataArray is empty + If dataArray.Count = 0 Then + MsgBox "There is no data if you this is an error please try again, if repeats please constact support.", vbExclamation, "No Data" + Exit Sub 'just stop doing anything else + End If + + ' Set up the headers in the first row just for a reference + Set headerRow = Sheets("Data").Range("A1") + + ' Dump the querys into the table so we can use it in our list :) + If json("success") Then + 'add the headers + ' Loop through the first item to get the keys (name, endpoint) + h = 1 + For Each Item In dataArray(1).Keys + ' Debug.Print Item + headerRow.Cells(5, h).Value = Item ' Place the key as a header + h = h + 1 + Next Item + + + ' Disable screen updating and calculations for faster execution + Application.ScreenUpdating = False + Application.Calculation = xlCalculationManual + + ' Debug.Print "Column count " & h + ' Populate data row by row + Dim cellValue As Variant + Dim rowIndex As Integer + rowIndex = 6 ' Start from row 6 + + For j = 1 To dataArray.Count ' Iterate from the first element of dataArray + For x = 1 To h + 'ws.Cells(rowIndex, x).Value = dataArray(j)(headerRow.Cells(5, x).Value) + cellValue = dataArray(j)(headerRow.Cells(5, x).Value) + + If VarType(cellValue) = vbString Then + ws.Cells(rowIndex, x).Value = "'" & cellValue ' Prefixing with apostrophe forces Excel to treat it as text + Else + ws.Cells(rowIndex, x).Value = cellValue + End If + Next x + rowIndex = rowIndex + 1 ' Move to the next row + Next j + + ' Re-enable screen updating and calculations + Application.ScreenUpdating = True + Application.Calculation = xlCalculationAutomatic + + ' Determine the last column used based on the number of headers + lastColumn = h + + ' Automatically adjust the width of all used columns + ws.Columns(1).Resize(, lastColumn).AutoFit ' Adjust based on last column + Sheets("Data").Select + MsgBox "Data processing successful!" + Else + MsgBox "Error: " & json("message") + End If + + + + + Exit Sub + +ErrorHandler: + ' Handle specific error for connection issues + If Err.Number = -2147012867 Then + MsgBox "Please make sure you are connected to vpn, and or make sure the server is online.", vbCritical + ElseIf Err.Number = -2147012894 Then + MsgBox "Server is not reachable please try again later." + + ' Handle other errors + MsgBox "An unexpected error occurred: " & Err.Description, vbCritical + End If + +End Sub diff --git a/GetDataAllPlants.bas b/GetDataAllPlants.bas new file mode 100644 index 0000000..7477965 --- /dev/null +++ b/GetDataAllPlants.bas @@ -0,0 +1,170 @@ +Attribute VB_Name = "GetDataAllPlants" +Sub getAllPlants(ByVal query As String) + + Dim req As New WinHttpRequest + + Dim json As Object + Dim dataArray As Object + Dim headerRow As Range + + Dim plantData As Range + Dim reqUrl As String + Dim firstRound As Boolean + Dim lastRow As Long + + 'where is our plant data to match too? + Set plantData = Sheet2.Range("A2:A30") + + Debug.Print "All plants running and the endpoint that will be hit: " & query + + 'check if the data sheet was removed or changed and recreate it it was changed and then clear the data + On Error Resume Next + Set ws = Sheets("Data") + If ws Is Nothing Then + Set ws = Sheets.Add + ws.Name = "Data" + Else + 'ws.Cells.Clear ' Clear existing data if the sheet already exists + End If + On Error GoTo 0 + + firstRound = False + + For Each cell In plantData + 'Debug.Print "Server that was selected : " & cell.Offset(0, 1).Value + + If cell.Value <> "" Then + ' we dont want to try and get localhost + If cell.Value = "Dev Server" Then + GoTo SkipIteration + End If + ' skip the test server too + If cell.Value = "TestServer" Then + GoTo SkipIteration + End If + + ' as iowa pet is on a differnt port we want to grab keep everything the same + If cell.Value = "Iowa ISBM, Iowa" Then + + reqUrl = "http://" & cell.Offset(0, 1).Value & ":3001" & query + Else + reqUrl = "http://" & cell.Offset(0, 1).Value & ":3000" & query + End If + + Debug.Print reqUrl + + On Error Resume Next ' Ignore errors and continue execution + + 'url is created get the request going. + req.Open "GET", reqUrl, False + + req.Send + + If Err.Number <> 0 Then + Debug.Print "An error occurred: " & Err.Description + Else + 'Debug.Print req.StatusText + + + + On Error GoTo 0 ' Reset error handling to default + + If req.Status <> 200 Then + Debug.Print req.Status & " - " & req.StatusText + Else + + + ' Get the response text (JSON) + jsonResponse = req.ResponseText + + Set json = JsonConverter.ParseJson(jsonResponse) + + Set dataArray = json("data") + 'how many we got + Debug.Print dataArray.Count + + ' Check if dataArray is empty + If dataArray.Count = 0 Then + 'MsgBox "There is no data for " & cell.Value & ", if you this is an error please try again, if repeats please constact support.", vbExclamation, "No Data" + + 'Exit Sub 'just stop doing anything else + End If + + + 'if we have over 15k lines just exit and direct the user to get the data from lst + If dataArray.Count > 15000 Then + MsgBox "There is more than 15,000 lines of data please, export the data from LST\n for perforance reasons no data will be loaded", vbExclamation, "No Data" + + 'Exit Sub 'just stop doing anything else + End If + + 'for the first plant we want to add the headers and then not do it again. + + ' Set up the headers in the first row just for a reference + Set headerRow = Sheets("Data").Range("A1") + + ' Dump the querys into the table so we can use it in our list :) + If json("success") Then + 'Debug.Print "First plant" + If Not firstRound Then + 'add the headers + Debug.Print "Running as first plant" + Sheets("Data").Range("A5:BB50000").ClearContents + ' Loop through the first item to get the keys (name, endpoint) + h = 1 + For Each Item In dataArray(1).Keys + 'Debug.Print Item + headerRow.Cells(5, h).Value = Item ' Place the key as a header + h = h + 1 + Next Item + firstRound = True + End If + + + + 'add the rows in. + + ' Disable screen updating and calculations for faster execution + Application.ScreenUpdating = False + Application.Calculation = xlCalculationManual + + ' Debug.Print "Column count " & h + ' Populate data row by row + 'For j = 1 To dataArray.Count + ' For x = 1 To h + ' 'Debug.Print dataArray(j)(headerRow.Cells(1, i).Value) + ' ws.Cells(j + 1, x).Value = dataArray(j)(headerRow.Cells(1, x).Value) + ' Next x + 'Next j + + 'Dim lastRow As Long + lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + lastRow = Application.Max(4, lastRow) + + ' Populate data row by row, starting from the lastRow + 1 + For j = 1 To dataArray.Count + For x = 1 To h + ws.Cells(lastRow + j, x).Value = dataArray(j)(headerRow.Cells(5, x).Value) + Next x + Next j + + ' Re-enable screen updating and calculations + Application.ScreenUpdating = True + Application.Calculation = xlCalculationAutomatic + + ' Determine the last column used based on the number of headers + lastColumn = h + + ' Automatically adjust the width of all used columns + ws.Columns(1).Resize(, lastColumn).AutoFit ' Adjust based on last column + End If + End If + End If + End If + +SkipIteration: ' Label to jump to the next iteration + + + Next cell + MsgBox "Data processing successful!" +End Sub diff --git a/JsonConverter.bas b/JsonConverter.bas new file mode 100644 index 0000000..876b865 --- /dev/null +++ b/JsonConverter.bas @@ -0,0 +1,1123 @@ +Attribute VB_Name = "JsonConverter" +'' +' VBA-JSON v2.3.1 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON +' +' JSON Converter for VBA +' +' Errors: +' 10001 - JSON parse error +' +' @class JsonConverter +' @author tim.hall.engr@gmail.com +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +' +' Based originally on vba-json (with extensive changes) +' BSD license included below +' +' JSONLib, http://code.google.com/p/vba-json/ +' +' Copyright (c) 2013, Ryo Yokoyama +' All rights reserved. +' +' Redistribution and use in source and binary forms, with or without +' modification, are permitted provided that the following conditions are met: +' * Redistributions of source code must retain the above copyright +' notice, this list of conditions and the following disclaimer. +' * Redistributions in binary form must reproduce the above copyright +' notice, this list of conditions and the following disclaimer in the +' documentation and/or other materials provided with the distribution. +' * Neither the name of the nor the +' names of its contributors may be used to endorse or promote products +' derived from this software without specific prior written permission. +' +' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +' DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +Option Explicit + +' === VBA-UTC Headers +#If Mac Then + +#If VBA7 Then + +' 64-bit Mac (2016) +Private Declare PtrSafe Function utc_popen Lib "/usr/lib/libc.dylib" Alias "popen" _ + (ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr +Private Declare PtrSafe Function utc_pclose Lib "/usr/lib/libc.dylib" Alias "pclose" _ + (ByVal utc_File As LongPtr) As LongPtr +Private Declare PtrSafe Function utc_fread Lib "/usr/lib/libc.dylib" Alias "fread" _ + (ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr +Private Declare PtrSafe Function utc_feof Lib "/usr/lib/libc.dylib" Alias "feof" _ + (ByVal utc_File As LongPtr) As LongPtr + +#Else + +' 32-bit Mac +Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _ + (ByVal utc_Command As String, ByVal utc_Mode As String) As Long +Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _ + (ByVal utc_File As Long) As Long +Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _ + (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long +Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _ + (ByVal utc_File As Long) As Long + +#End If + +#ElseIf VBA7 Then + +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx +Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long +Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long +Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long + +#Else + +Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long +Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long +Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long + +#End If + +#If Mac Then + +#If VBA7 Then +Private Type utc_ShellResult + utc_Output As String + utc_ExitCode As LongPtr +End Type + +#Else + +Private Type utc_ShellResult + utc_Output As String + utc_ExitCode As Long +End Type + +#End If + +#Else + +Private Type utc_SYSTEMTIME + utc_wYear As Integer + utc_wMonth As Integer + utc_wDayOfWeek As Integer + utc_wDay As Integer + utc_wHour As Integer + utc_wMinute As Integer + utc_wSecond As Integer + utc_wMilliseconds As Integer +End Type + +Private Type utc_TIME_ZONE_INFORMATION + utc_Bias As Long + utc_StandardName(0 To 31) As Integer + utc_StandardDate As utc_SYSTEMTIME + utc_StandardBias As Long + utc_DaylightName(0 To 31) As Integer + utc_DaylightDate As utc_SYSTEMTIME + utc_DaylightBias As Long +End Type + +#End If +' === End VBA-UTC + +Private Type json_Options + ' VBA only stores 15 significant digits, so any numbers larger than that are truncated + ' 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 + ' See: http://support.microsoft.com/kb/269370 + ' + ' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits + ' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True` + UseDoubleForLargeNumbers As Boolean + + ' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys + AllowUnquotedKeys As Boolean + + ' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson + EscapeSolidus As Boolean +End Type +Public JsonOptions As json_Options + +' ============================================= ' +' Public Methods +' ============================================= ' + +'' +' Convert JSON string to object (Dictionary/Collection) +' +' @method ParseJson +' @param {String} json_String +' @return {Object} (Dictionary or Collection) +' @throws 10001 - JSON parse error +'' +Public Function ParseJson(ByVal JsonString As String) As Object + Dim json_Index As Long + json_Index = 1 + + ' Remove vbCr, vbLf, and vbTab from json_String + JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "") + + json_SkipSpaces JsonString, json_Index + Select Case VBA.Mid$(JsonString, json_Index, 1) + Case "{" + Set ParseJson = json_ParseObject(JsonString, json_Index) + Case "[" + Set ParseJson = json_ParseArray(JsonString, json_Index) + Case Else + ' Error: Invalid JSON string + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['") + End Select +End Function + +'' +' Convert object (Dictionary/Collection/Array) to JSON +' +' @method ConvertToJson +' @param {Variant} JsonValue (Dictionary, Collection, or Array) +' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string +' @return {String} +'' +Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + Dim json_Index As Long + Dim json_LBound As Long + Dim json_UBound As Long + Dim json_IsFirstItem As Boolean + Dim json_Index2D As Long + Dim json_LBound2D As Long + Dim json_UBound2D As Long + Dim json_IsFirstItem2D As Boolean + Dim json_Key As Variant + Dim json_Value As Variant + Dim json_DateStr As String + Dim json_Converted As String + Dim json_SkipItem As Boolean + Dim json_PrettyPrint As Boolean + Dim json_Indentation As String + Dim json_InnerIndentation As String + + json_LBound = -1 + json_UBound = -1 + json_IsFirstItem = True + json_LBound2D = -1 + json_UBound2D = -1 + json_IsFirstItem2D = True + json_PrettyPrint = Not IsMissing(Whitespace) + + Select Case VBA.VarType(JsonValue) + Case VBA.vbNull + ConvertToJson = "null" + Case VBA.vbDate + ' Date + json_DateStr = ConvertToIso(VBA.CDate(JsonValue)) + + ConvertToJson = """" & json_DateStr & """" + Case VBA.vbString + ' String (or large number encoded as string) + If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then + ConvertToJson = JsonValue + Else + ConvertToJson = """" & json_Encode(JsonValue) & """" + End If + Case VBA.vbBoolean + If JsonValue Then + ConvertToJson = "true" + Else + ConvertToJson = "false" + End If + Case VBA.vbArray To VBA.vbArray + VBA.vbByte + If json_PrettyPrint Then + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) + json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace) + Else + json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) + json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace) + End If + End If + + ' Array + json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength + + On Error Resume Next + + json_LBound = LBound(JsonValue, 1) + json_UBound = UBound(JsonValue, 1) + json_LBound2D = LBound(JsonValue, 2) + json_UBound2D = UBound(JsonValue, 2) + + If json_LBound >= 0 And json_UBound >= 0 Then + For json_Index = json_LBound To json_UBound + If json_IsFirstItem Then + json_IsFirstItem = False + Else + ' Append comma to previous line + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + If json_LBound2D >= 0 And json_UBound2D >= 0 Then + ' 2D Array + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + End If + json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength + + For json_Index2D = json_LBound2D To json_UBound2D + If json_IsFirstItem2D Then + json_IsFirstItem2D = False + Else + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_InnerIndentation & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + Next json_Index2D + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + End If + + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + json_IsFirstItem2D = True + Else + ' 1D Array + json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(JsonValue(json_Index)) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + End If + Next json_Index + End If + + On Error GoTo 0 + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + + ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) + + ' Dictionary or Collection + Case VBA.vbObject + If json_PrettyPrint Then + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) + Else + json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) + End If + End If + + ' Dictionary + If VBA.TypeName(JsonValue) = "Dictionary" Then + json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength + For Each json_Key In JsonValue.Keys + ' For Objects, undefined (Empty/Nothing) is not added to object + json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1) + If json_Converted = "" Then + json_SkipItem = json_IsUndefined(JsonValue(json_Key)) + Else + json_SkipItem = False + End If + + If Not json_SkipItem Then + If json_IsFirstItem Then + json_IsFirstItem = False + Else + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted + Else + json_Converted = """" & json_Key & """:" & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + End If + Next json_Key + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength + + ' Collection + ElseIf VBA.TypeName(JsonValue) = "Collection" Then + json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength + For Each json_Value In JsonValue + If json_IsFirstItem Then + json_IsFirstItem = False + Else + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(json_Value) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + Next json_Value + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + End If + + ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) + Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal + ' Number (use decimals for numbers) + ConvertToJson = VBA.Replace(JsonValue, ",", ".") + Case Else + ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType + ' Use VBA's built-in to-string + On Error Resume Next + ConvertToJson = JsonValue + On Error GoTo 0 + End Select +End Function + +' ============================================= ' +' Private Functions +' ============================================= ' + +Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary + Dim json_Key As String + Dim json_NextChar As String + + Set json_ParseObject = New Dictionary + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> "{" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'") + Else + json_Index = json_Index + 1 + + Do + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) = "}" Then + json_Index = json_Index + 1 + Exit Function + ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then + json_Index = json_Index + 1 + json_SkipSpaces json_String, json_Index + End If + + json_Key = json_ParseKey(json_String, json_Index) + json_NextChar = json_Peek(json_String, json_Index) + If json_NextChar = "[" Or json_NextChar = "{" Then + Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) + Else + json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) + End If + Loop + End If +End Function + +Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection + Set json_ParseArray = New Collection + + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> "[" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['") + Else + json_Index = json_Index + 1 + + Do + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) = "]" Then + json_Index = json_Index + 1 + Exit Function + ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then + json_Index = json_Index + 1 + json_SkipSpaces json_String, json_Index + End If + + json_ParseArray.Add json_ParseValue(json_String, json_Index) + Loop + End If +End Function + +Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant + json_SkipSpaces json_String, json_Index + Select Case VBA.Mid$(json_String, json_Index, 1) + Case "{" + Set json_ParseValue = json_ParseObject(json_String, json_Index) + Case "[" + Set json_ParseValue = json_ParseArray(json_String, json_Index) + Case """", "'" + json_ParseValue = json_ParseString(json_String, json_Index) + Case Else + If VBA.Mid$(json_String, json_Index, 4) = "true" Then + json_ParseValue = True + json_Index = json_Index + 4 + ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then + json_ParseValue = False + json_Index = json_Index + 5 + ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then + json_ParseValue = Null + json_Index = json_Index + 4 + ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then + json_ParseValue = json_ParseNumber(json_String, json_Index) + Else + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['") + End If + End Select +End Function + +Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String + Dim json_Quote As String + Dim json_Char As String + Dim json_Code As String + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + + json_SkipSpaces json_String, json_Index + + ' Store opening quote to look for matching closing quote + json_Quote = VBA.Mid$(json_String, json_Index, 1) + json_Index = json_Index + 1 + + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + + Select Case json_Char + Case "\" + ' Escaped string, \\, or \/ + json_Index = json_Index + 1 + json_Char = VBA.Mid$(json_String, json_Index, 1) + + Select Case json_Char + Case """", "\", "/", "'" + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "b" + json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "f" + json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "n" + json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "r" + json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "t" + json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "u" + ' Unicode character escape (e.g. \u00a9 = Copyright) + json_Index = json_Index + 1 + json_Code = VBA.Mid$(json_String, json_Index, 4) + json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength + json_Index = json_Index + 4 + End Select + Case json_Quote + json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition) + json_Index = json_Index + 1 + Exit Function + Case Else + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + End Select + Loop +End Function + +Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant + Dim json_Char As String + Dim json_Value As String + Dim json_IsLargeNumber As Boolean + + json_SkipSpaces json_String, json_Index + + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + + If VBA.InStr("+-0123456789.eE", json_Char) Then + ' Unlikely to have massive number, so use simple append rather than buffer here + json_Value = json_Value & json_Char + json_Index = json_Index + 1 + Else + ' Excel only stores 15 significant digits, so any numbers larger than that are truncated + ' 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 + ' See: http://support.microsoft.com/kb/269370 + ' + ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number + ' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16) + json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16) + If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then + json_ParseNumber = json_Value + Else + ' VBA.Val does not use regional settings, so guard for comma is not needed + json_ParseNumber = VBA.Val(json_Value) + End If + Exit Function + End If + Loop +End Function + +Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String + ' Parse key with single or double quotes + If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then + json_ParseKey = json_ParseString(json_String, json_Index) + ElseIf JsonOptions.AllowUnquotedKeys Then + Dim json_Char As String + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + If (json_Char <> " ") And (json_Char <> ":") Then + json_ParseKey = json_ParseKey & json_Char + json_Index = json_Index + 1 + Else + Exit Do + End If + Loop + Else + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''") + End If + + ' Check for colon and skip if present or throw if not present + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> ":" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'") + Else + json_Index = json_Index + 1 + End If +End Function + +Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean + ' Empty / Nothing -> undefined + Select Case VBA.VarType(json_Value) + Case VBA.vbEmpty + json_IsUndefined = True + Case VBA.vbObject + Select Case VBA.TypeName(json_Value) + Case "Empty", "Nothing" + json_IsUndefined = True + End Select + End Select +End Function + +Private Function json_Encode(ByVal json_Text As Variant) As String + ' Reference: http://www.ietf.org/rfc/rfc4627.txt + ' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab + Dim json_Index As Long + Dim json_Char As String + Dim json_AscCode As Long + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + + For json_Index = 1 To VBA.Len(json_Text) + json_Char = VBA.Mid$(json_Text, json_Index, 1) + json_AscCode = VBA.AscW(json_Char) + + ' When AscW returns a negative number, it returns the twos complement form of that number. + ' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result. + ' https://support.microsoft.com/en-us/kb/272138 + If json_AscCode < 0 Then + json_AscCode = json_AscCode + 65536 + End If + + ' From spec, ", \, and control characters must be escaped (solidus is optional) + + Select Case json_AscCode + Case 34 + ' " -> 34 -> \" + json_Char = "\""" + Case 92 + ' \ -> 92 -> \\ + json_Char = "\\" + Case 47 + ' / -> 47 -> \/ (optional) + If JsonOptions.EscapeSolidus Then + json_Char = "\/" + End If + Case 8 + ' backspace -> 8 -> \b + json_Char = "\b" + Case 12 + ' form feed -> 12 -> \f + json_Char = "\f" + Case 10 + ' line feed -> 10 -> \n + json_Char = "\n" + Case 13 + ' carriage return -> 13 -> \r + json_Char = "\r" + Case 9 + ' tab -> 9 -> \t + json_Char = "\t" + Case 0 To 31, 127 To 65535 + ' Non-ascii characters -> convert to 4-digit hex + json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4) + End Select + + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength + Next json_Index + + json_Encode = json_BufferToString(json_Buffer, json_BufferPosition) +End Function + +Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String + ' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef) + json_SkipSpaces json_String, json_Index + json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters) +End Function + +Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long) + ' Increment index to skip over spaces + Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " " + json_Index = json_Index + 1 + Loop +End Sub + +Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean + ' Check if the given string is considered a "large number" + ' (See json_ParseNumber) + + Dim json_Length As Long + Dim json_CharIndex As Long + json_Length = VBA.Len(json_String) + + ' Length with be at least 16 characters and assume will be less than 100 characters + If json_Length >= 16 And json_Length <= 100 Then + Dim json_CharCode As String + + json_StringIsLargeNumber = True + + For json_CharIndex = 1 To json_Length + json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1)) + Select Case json_CharCode + ' Look for .|0-9|E|e + Case 46, 48 To 57, 69, 101 + ' Continue through characters + Case Else + json_StringIsLargeNumber = False + Exit Function + End Select + Next json_CharIndex + End If +End Function + +Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, ErrorMessage As String) + ' Provide detailed parse error message, including details of where and what occurred + ' + ' Example: + ' Error parsing JSON: + ' {"abcde":True} + ' ^ + ' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '[' + + Dim json_StartIndex As Long + Dim json_StopIndex As Long + + ' Include 10 characters before and after error (if possible) + json_StartIndex = json_Index - 10 + json_StopIndex = json_Index + 10 + If json_StartIndex <= 0 Then + json_StartIndex = 1 + End If + If json_StopIndex > VBA.Len(json_String) Then + json_StopIndex = VBA.Len(json_String) + End If + + json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _ + VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _ + VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _ + ErrorMessage +End Function + +Private Sub json_BufferAppend(ByRef json_Buffer As String, _ + ByRef json_Append As Variant, _ + ByRef json_BufferPosition As Long, _ + ByRef json_BufferLength As Long) + ' VBA can be slow to append strings due to allocating a new string for each append + ' Instead of using the traditional append, allocate a large empty string and then copy string at append position + ' + ' Example: + ' Buffer: "abc " + ' Append: "def" + ' Buffer Position: 3 + ' Buffer Length: 5 + ' + ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer + ' Buffer: "abc " + ' Buffer Length: 10 + ' + ' Put "def" into buffer at position 3 (0-based) + ' Buffer: "abcdef " + ' + ' Approach based on cStringBuilder from vbAccelerator + ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp + ' + ' and clsStringAppend from Philip Swannell + ' https://github.com/VBA-tools/VBA-JSON/pull/82 + + Dim json_AppendLength As Long + Dim json_LengthPlusPosition As Long + + json_AppendLength = VBA.Len(json_Append) + json_LengthPlusPosition = json_AppendLength + json_BufferPosition + + If json_LengthPlusPosition > json_BufferLength Then + ' Appending would overflow buffer, add chunk + ' (double buffer length or append length, whichever is bigger) + Dim json_AddedLength As Long + json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength) + + json_Buffer = json_Buffer & VBA.Space$(json_AddedLength) + json_BufferLength = json_BufferLength + json_AddedLength + End If + + ' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error: + ' Function call on left-hand side of assignment must return Variant or Object + Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append) + json_BufferPosition = json_BufferPosition + json_AppendLength +End Sub + +Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String + If json_BufferPosition > 0 Then + json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition) + End If +End Function + +'' +' VBA-UTC v1.0.6 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter +' +' UTC/ISO 8601 Converter for VBA +' +' Errors: +' 10011 - UTC parsing error +' 10012 - UTC conversion error +' 10013 - ISO 8601 parsing error +' 10014 - ISO 8601 conversion error +' +' @module UtcConverter +' @author tim.hall.engr@gmail.com +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' + +' (Declarations moved to top) + +' ============================================= ' +' Public Methods +' ============================================= ' + +'' +' Parse UTC date to local date +' +' @method ParseUtc +' @param {Date} UtcDate +' @return {Date} Local date +' @throws 10011 - UTC parsing error +'' +Public Function ParseUtc(utc_UtcDate As Date) As Date + On Error GoTo utc_ErrorHandling + +#If Mac Then + ParseUtc = utc_ConvertDate(utc_UtcDate) +#Else + Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION + Dim utc_LocalDate As utc_SYSTEMTIME + + utc_GetTimeZoneInformation utc_TimeZoneInfo + utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate + + ParseUtc = utc_SystemTimeToDate(utc_LocalDate) +#End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description +End Function + +'' +' Convert local date to UTC date +' +' @method ConvertToUrc +' @param {Date} utc_LocalDate +' @return {Date} UTC date +' @throws 10012 - UTC conversion error +'' +Public Function ConvertToUtc(utc_LocalDate As Date) As Date + On Error GoTo utc_ErrorHandling + +#If Mac Then + ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True) +#Else + Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION + Dim utc_UtcDate As utc_SYSTEMTIME + + utc_GetTimeZoneInformation utc_TimeZoneInfo + utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate + + ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate) +#End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description +End Function + +'' +' Parse ISO 8601 date string to local date +' +' @method ParseIso +' @param {Date} utc_IsoString +' @return {Date} Local date +' @throws 10013 - ISO 8601 parsing error +'' +Public Function ParseIso(utc_IsoString As String) As Date + On Error GoTo utc_ErrorHandling + + Dim utc_Parts() As String + Dim utc_DateParts() As String + Dim utc_TimeParts() As String + Dim utc_OffsetIndex As Long + Dim utc_HasOffset As Boolean + Dim utc_NegativeOffset As Boolean + Dim utc_OffsetParts() As String + Dim utc_Offset As Date + + utc_Parts = VBA.Split(utc_IsoString, "T") + utc_DateParts = VBA.Split(utc_Parts(0), "-") + ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2))) + + If UBound(utc_Parts) > 0 Then + If VBA.InStr(utc_Parts(1), "Z") Then + utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":") + Else + utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+") + If utc_OffsetIndex = 0 Then + utc_NegativeOffset = True + utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-") + End If + + If utc_OffsetIndex > 0 Then + utc_HasOffset = True + utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":") + utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":") + + Select Case UBound(utc_OffsetParts) + Case 0 + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0) + Case 1 + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0) + Case 2 + ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2)))) + End Select + + If utc_NegativeOffset Then: utc_Offset = -utc_Offset + Else + utc_TimeParts = VBA.Split(utc_Parts(1), ":") + End If + End If + + Select Case UBound(utc_TimeParts) + Case 0 + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0) + Case 1 + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0) + Case 2 + ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2)))) + End Select + + ParseIso = ParseUtc(ParseIso) + + If utc_HasOffset Then + ParseIso = ParseIso - utc_Offset + End If + End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description +End Function + +'' +' Convert local date to ISO 8601 string +' +' @method ConvertToIso +' @param {Date} utc_LocalDate +' @return {Date} ISO 8601 string +' @throws 10014 - ISO 8601 conversion error +'' +Public Function ConvertToIso(utc_LocalDate As Date) As String + On Error GoTo utc_ErrorHandling + + ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z") + + Exit Function + +utc_ErrorHandling: + Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description +End Function + +' ============================================= ' +' Private Functions +' ============================================= ' + +#If Mac Then + +Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date + Dim utc_ShellCommand As String + Dim utc_Result As utc_ShellResult + Dim utc_Parts() As String + Dim utc_DateParts() As String + Dim utc_TimeParts() As String + + If utc_ConvertToUtc Then + utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _ + "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _ + " +'%s'` +'%Y-%m-%d %H:%M:%S'" + Else + utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _ + "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _ + "+'%Y-%m-%d %H:%M:%S'" + End If + + utc_Result = utc_ExecuteInShell(utc_ShellCommand) + + If utc_Result.utc_Output = "" Then + Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed" + Else + utc_Parts = Split(utc_Result.utc_Output, " ") + utc_DateParts = Split(utc_Parts(0), "-") + utc_TimeParts = Split(utc_Parts(1), ":") + + utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _ + TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2)) + End If +End Function + +Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult +#If VBA7 Then + Dim utc_File As LongPtr + Dim utc_Read As LongPtr +#Else + Dim utc_File As Long + Dim utc_Read As Long +#End If + + Dim utc_Chunk As String + + On Error GoTo utc_ErrorHandling + utc_File = utc_popen(utc_ShellCommand, "r") + + If utc_File = 0 Then: Exit Function + + Do While utc_feof(utc_File) = 0 + utc_Chunk = VBA.Space$(50) + utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File)) + If utc_Read > 0 Then + utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read)) + utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk + End If + Loop + +utc_ErrorHandling: + utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File)) +End Function + +#Else + +Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME + utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value) + utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value) + utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value) + utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value) + utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value) + utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value) + utc_DateToSystemTime.utc_wMilliseconds = 0 +End Function + +Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date + utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _ + TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond) +End Function + +#End If diff --git a/MacroTemplate2.0.xlsm b/MacroTemplate2.0.xlsm index 5c98083..c278327 100644 Binary files a/MacroTemplate2.0.xlsm and b/MacroTemplate2.0.xlsm differ diff --git a/ThisWorkbook.cls b/ThisWorkbook.cls new file mode 100644 index 0000000..568bd53 --- /dev/null +++ b/ThisWorkbook.cls @@ -0,0 +1,3 @@ +Private Sub Workbook_Open() +Call queryAvi +End Sub