diff --git a/Master Template.xlsm_EXPORTS/JsonConverter.bas b/Master Template.xlsm_EXPORTS/JsonConverter.bas new file mode 100644 index 0000000..f9dc6c1 --- /dev/null +++ b/Master Template.xlsm_EXPORTS/JsonConverter.bas @@ -0,0 +1,1125 @@ +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/Master Template.xlsm_EXPORTS/JsonDebugPrint.bas b/Master Template.xlsm_EXPORTS/JsonDebugPrint.bas new file mode 100644 index 0000000..12e284f --- /dev/null +++ b/Master Template.xlsm_EXPORTS/JsonDebugPrint.bas @@ -0,0 +1,43 @@ +Attribute VB_Name = "JsonDebugPrint" +Option Explicit + + +Public Sub TestPrintJSON() + PrintJSON ParseJson("[1,2,3]") + PrintJSON ParseJson("[{""a"":123,""b"":[56,7,78]}]") +End Sub + +' This is definitely NOT a pretty printer. It was written merely as a debugging +' tool to make sense of the objects that come out of JsonConverter.ParseJSON. +' It doesn't format in the best way possible, but it does provide a semi-readable +' view of the data in the JSON object. +' Phil Runninger 3/1/2023 +' +Public Sub PrintJSON(obj As Variant, Optional level As Integer = 0) + Dim itm As Variant + Dim first As Boolean + Select Case TypeName(obj) + Case "Dictionary" + Debug.Print String(level * 2, " "); "{" + first = True + For Each itm In obj + If Not first Then Debug.Print String((level + 1) * 2, " "); "," + first = False + Debug.Print String((level + 1) * 2, " "); itm; ":"; + PrintJSON obj(itm), level + 1 + Next + Debug.Print String(level * 2, " "); "}" + Case "Collection" + Debug.Print String(level * 2, " "); "[" + first = True + For Each itm In obj + If Not first Then Debug.Print String(level * 2, " "); "," + first = False + PrintJSON itm, level + 1 + Next + Debug.Print String(level * 2, " "); "]" + Case Else + Debug.Print String(level * 2, " "); obj; + End Select +End Sub + diff --git a/Master Template.xlsm_EXPORTS/ThisWorkbook.cls b/Master Template.xlsm_EXPORTS/ThisWorkbook.cls new file mode 100644 index 0000000..71a3598 --- /dev/null +++ b/Master Template.xlsm_EXPORTS/ThisWorkbook.cls @@ -0,0 +1,9 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ThisWorkbook" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True diff --git a/Master Template.xlsm_EXPORTS/Utils.bas b/Master Template.xlsm_EXPORTS/Utils.bas new file mode 100644 index 0000000..4cc22f3 --- /dev/null +++ b/Master Template.xlsm_EXPORTS/Utils.bas @@ -0,0 +1,620 @@ +Attribute VB_Name = "Utils" +Option Explicit + +Public ADOo_errstring As String + +Public Function TBLp_Aggregate(ByRef tbl() As String, ByRef needsort As Boolean, ByRef headers As Boolean, ByRef del_unused As Boolean, ParamArray groupnum_type_sumnum()) As Boolean + + Dim i As Long + Dim j As Long + Dim nt() As String + Dim keep() As Integer + + If needsort Then + If Not TBLp_BubbleSortAsc(tbl, PAp_2DGetIntegerArray(0, groupnum_type_sumnum), PAp_2DGetStringArray(1, groupnum_type_sumnum), headers) Then + TBLp_Aggregate = False + Exit Function + End If + End If + + If Not TBLp_Roll(tbl, PAp_2DGetIntegerArray(0, groupnum_type_sumnum), PAp_2DGetIntegerArray(2, groupnum_type_sumnum), headers) Then + TBLp_Aggregate = False + Exit Function + End If + + + If del_unused Then + keep = PAp_2DGetMultIntegerArray(ARRAYp_MakeInteger(0, 2), groupnum_type_sumnum) + ReDim nt(UBound(keep()), UBound(tbl, 2)) + For i = 0 To UBound(keep()) + For j = 0 To UBound(tbl, 2) + nt(i, j) = tbl(keep(i), j) + Next j + Next i + tbl = nt + End If + + TBLp_Aggregate = True + +End Function + +Function TBLp_BubbleSortAsc(ByRef tbl() As String, ByRef sortflds() As Integer, ByRef typeflds() As String, ByRef headers As Boolean) As Boolean + +On Error GoTo errh + 'get fort field numbers + 'loop through each row and generate the row key + 'eveluate the row key against other row keys + 'perform swaps + + Dim i As Long + Dim j As Long + Dim k As Long + + k = 0 + If headers Then k = 1 + + For i = k To UBound(tbl, 2) - 1 + For j = i + 1 To UBound(tbl, 2) + If ROWe_AscSwapFlag(tbl, i, j, sortflds, typeflds) Then + Call ROWp_Swap(tbl, i, j) + Else + If ADOo_errstring <> "" Then + TBLp_BubbleSortAsc = False + Exit Function + End If + End If + Next j + Next i + +errh: + If Err.Number <> 0 Then + MsgBox ("Error at TBLP_BubbleSortAsc." & vbCrLf & Err.Description) + ADOo_errstring = Err.Description + End If + + TBLp_BubbleSortAsc = True + +End Function + +Public Function TBLp_Roll(ByRef tbl() As String, ByRef gflds() As Integer, ByRef sflds() As Integer, ByRef headers As Boolean) As Boolean + +On Error GoTo errh + Dim i As Long 'indexes primary row + Dim j As Long 'indexes secondary chaecker row + Dim k As Integer 'used to start at 0 or 1 + Dim m As Long 'used to aggregate on sequencing lines (i and j aggregate to m line) then shorten array to m length - 1 + + k = 0 + If headers Then k = 1 + m = k + For i = k To UBound(tbl, 2) + If i = UBound(tbl, 2) Then + i = i + End If + j = i + 1 + Do + If j > UBound(tbl, 2) Then Exit Do + If ROWe_MatchesFlag(tbl, i, j, gflds) Then + Call ROWp_Aggregate2Rows(tbl, i, j, sflds) + Else + Exit Do + End If + j = j + 1 + If j > UBound(tbl, 2) Then + Exit Do + End If + Loop + Call ROWp_Copy(tbl, i, m) + m = m + 1 + i = j - 1 + Next i + + ReDim Preserve tbl(UBound(tbl, 1), m - 1) + +errh: + If Err.Number <> 0 Then + ADOo_errstring = Err.Description + TBLp_Roll = False + Exit Function + End If + + TBLp_Roll = True + +End Function + +Sub ROWp_Swap(ByRef tbl() As String, ByRef p1 As Long, ByRef p2 As Long) + + Dim temprow() As String + ReDim temprow(UBound(tbl, 1)) + Dim i As Integer + + For i = 0 To UBound(tbl, 1) + temprow(i) = tbl(i, p2) + Next i + + For i = 0 To UBound(tbl, 1) + tbl(i, p2) = tbl(i, p1) + Next i + + For i = 0 To UBound(tbl, 1) + tbl(i, p1) = temprow(i) + Next i + +End Sub + +Sub ROWp_Copy(ByRef tbl() As String, ByRef r_from As Long, ByRef r_to As Long) + + Dim i As Integer + + For i = 0 To UBound(tbl, 1) + tbl(i, r_to) = tbl(i, r_from) + Next i + +End Sub + +Sub ROWp_Aggregate2Rows(ByRef tbl() As String, ByRef p1 As Long, ByRef p2 As Long, ByRef sflds() As Integer) + + Dim i As Integer + On Error GoTo exitsub + For i = 0 To UBound(sflds, 1) + tbl(sflds(i), p1) = CDbl(tbl(sflds(i), p1)) + CDbl(tbl(sflds(i), p2)) + Next i + +exitsub: + +End Sub + +Function ROWe_AscSwapFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer, ByRef TypeFld() As String) As Boolean + 'only returns true if greater than + +On Error GoTo errh + Dim i As Integer + Dim compare As Integer + + For i = 0 To UBound(KeyFld) + Select Case TypeFld(i) + Case "S" + compare = MISCe_CompareString(CStr(tbl(KeyFld(i), row1)), CStr(tbl(KeyFld(i), row2))) + Case "N" + compare = MISCe_CompareDouble(CDbl(tbl(KeyFld(i), row1)), CDbl(tbl(KeyFld(i), row2))) + Case "D" + compare = MISCe_CompareDate(CDate(tbl(KeyFld(i), row1)), CDate(tbl(KeyFld(i), row2))) + End Select + Select Case compare + Case -1 + ROWe_AscSwapFlag = True + Exit Function + Case 1 + ROWe_AscSwapFlag = False + Exit Function + End Select + Next i + +errh: + If Err.Number <> 0 Then + MsgBox ("Error at ROWe_AscSwapFlag." & vbCrLf & Err.Description) + ADOo_errstring = Err.Description + Exit Function + End If + +End Function + +Function ROWe_MatchesFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer) As Boolean + 'only returns true if greater than + + Dim i As Integer + Dim k1 As String + Dim k2 As String + + For i = 0 To UBound(KeyFld()) + k1 = k1 & tbl(KeyFld(i), row1) + Next i + + For i = 0 To UBound(KeyFld()) + k2 = k2 & tbl(KeyFld(i), row2) + Next i + + + If k2 = k1 Then + ROWe_MatchesFlag = True + Else + ROWe_MatchesFlag = False + End If + +End Function + +Sub SHTp_DumpVar(ByRef tbl() As Variant, ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef clear As Boolean, ByRef transpose As Boolean, ByRef zerobase As Boolean) + + Dim sh As Worksheet + Dim address As String + Set sh = Sheets(sheet) + + 'If clear Then sh.Cells.clear + 'If transpose Then Call ARRAYp_Transpose(tbl) + If zerobase Then + address = sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1), col + UBound(tbl, 2)).address + Else + address = sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1) - 1, col + UBound(tbl, 2) - 1).address + End If + sh.Range(address).FormulaR1C1 = tbl + + On Error GoTo errhndl + + +errhndl: + If Err.Number <> 0 Then MsgBox ("Error in dumping to sheet" & vbCrLf & Err.Description) + + +End Sub + +Function ARRAYp_TransposeVar(ByRef a() As Variant) As Variant() + + Dim s() As Variant + ReDim s(UBound(a, 2), UBound(a, 1)) + + Dim i As Long + Dim j As Long + + For i = 0 To UBound(s, 1) + For j = 0 To UBound(s, 2) + s(i, j) = a(j, i) + Next j + Next i + + ARRAYp_TransposeVar = s + +End Function + +Function ARRAYp_zerobased_addheader(ByRef z() As Variant, ParamArray cols()) As Variant() + + Dim i As Long + Dim j As Long + + Dim r() As Variant + ReDim r(UBound(z, 1), UBound(z, 2) + 1) + + For i = 0 To UBound(r, 1) + For j = 1 To UBound(r, 2) + r(i, j) = z(i, j - 1) + Next j + r(i, 0) = cols(i) + Next i + + ARRAYp_zerobased_addheader = r + +End Function + +Public Function SHTp_Get(ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef headers As Boolean) As String() + + Dim i As Long + Dim j As Long + Dim table() As String + Dim sh As Worksheet + Set sh = Sheets(sheet) + + On Error GoTo errhdnl + + i = 1 + While sh.Cells(row, col + i - 1) <> "" + i = i + 1 + Wend + + j = 1 + While sh.Cells(row + j - 1, col) <> "" + j = j + 1 + Wend + + ReDim table(i - 2, j - 2) + i = 1 + While i <= UBound(table, 1) + 1 + j = 0 + While j <= UBound(table, 2) + table(i - 1, j) = sh.Cells(row + j, col + i - 1) + j = j + 1 + Wend + i = i + 1 + Wend + +errhdnl: + If Err.Number <> 0 Then + MsgBox (Err.Description) + End If + + SHTp_Get = table + +End Function + +Function PAp_2DGetStringArray(ByRef index As Integer, ParamArray pa()) As String() + + Dim str() As String + Dim i As Long + ReDim str(UBound(pa(0)(index))) + + For i = 0 To UBound(pa(0)(index)) + str(i) = pa(0)(index)(i) + Next i + PAp_2DGetStringArray = str + +End Function + +Function PAp_2DGetIntegerArray(ByRef index As Integer, ParamArray pa()) As Integer() + + Dim str() As Integer + Dim i As Long + If UBound(pa(0)(index)) <> -1 Then + ReDim str(UBound(pa(0)(index))) + + For i = 0 To UBound(pa(0)(index)) + str(i) = pa(0)(index)(i) + Next i + End If + PAp_2DGetIntegerArray = str + +End Function + +Function PAp_2DGetMultIntegerArray(ByRef ArraysGet() As Integer, ParamArray pa()) As Integer() + + Dim str() As Integer + Dim i As Long + Dim j As Long + Dim cnt As Long + Dim index As Long + + + 'get length of selected arrays + For i = 0 To UBound(ArraysGet, 1) + cnt = cnt + UBound(pa(0)(ArraysGet(i))) + Next i + + ReDim str(cnt + 1) + cnt = 0 + + For i = 0 To UBound(ArraysGet, 1) + For j = 0 To UBound(pa(0)(ArraysGet(i))) + str(cnt) = pa(0)(ArraysGet(i))(j) + cnt = cnt + 1 + Next j + Next i + + PAp_2DGetMultIntegerArray = str + +End Function + +Public Function ARRAYp_MakeInteger(ParamArray items()) As Integer() + + Dim X() As Integer + Dim i As Integer + ReDim X(UBound(items)) + + For i = 0 To UBound(items()) + X(i) = items(i) + Next i + + ARRAYp_MakeInteger = X + +End Function + +Public Function MISCe_CompareString(ByRef base As String, ByRef compare As String) As Integer + + If compare < base Then + MISCe_CompareString = -1 + Exit Function + End If + + If compare = base Then + MISCe_CompareString = 0 + Exit Function + End If + + If compare > base Then + MISCe_CompareString = 1 + Exit Function + End If + +End Function + +Public Function MISCe_CompareDouble(ByRef base As Double, ByRef compare As Double) As Integer + + If compare < base Then + MISCe_CompareDouble = -1 + Exit Function + End If + + If compare = base Then + MISCe_CompareDouble = 0 + Exit Function + End If + + If compare > base Then + MISCe_CompareDouble = 1 + Exit Function + End If + +End Function + +Public Function MISCe_CompareDate(ByRef base As Date, ByRef compare As Date) As Integer + + + If compare < base Then + MISCe_CompareDate = -1 + Exit Function + End If + + If compare = base Then + MISCe_CompareDate = 0 + Exit Function + End If + + If compare > base Then + MISCe_CompareDate = 1 + Exit Function + End If + +End Function + +Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As String, Optional strip_braces As Boolean) As String + + + Dim ajson As String + Dim json As String + Dim r As Integer + Dim c As Integer + Dim needs_comma As Boolean + Dim needs_braces As Integer + + needs_comma = False + needs_braces = 0 + ajson = "" + + For r = 2 To UBound(tbl, 1) + For c = 1 To UBound(tbl, 2) + If tbl(r, c) <> "" Then + needs_braces = needs_braces + 1 + If needs_comma Then json = json & "," + needs_comma = True + If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then + json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & tbl(r, c) + Else + 'test if item is a json object + If Mid(tbl(r, c), 1, 1) = "{" Or Mid(tbl(r, c), 1, 1) = "[" Then + json = json & """" & tbl(1, c) & """" & ":" & tbl(r, c) + Else + json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34) + End If + End If + End If + Next c + If needs_braces > 0 Then json = "{" & json & "}" + needs_comma = False + needs_braces = 0 + If r > 2 Then + ajson = ajson & "," & json + Else + ajson = json + End If + json = "" + Next r + + 'if theres more the one record, include brackets for array + 'if an array_label is given give the array a key and the array become the value + 'then if the array is labeled with a key it should have braces unless specified otherwise + If r > 3 Then + ajson = "[" & ajson & "]" + If array_label <> "" Then + ajson = """" & array_label & """:" & ajson + If Not strip_braces Then + ajson = "{" & ajson & "}" + End If + End If + Else + If strip_braces Then + ajson = Mid(ajson, 2, Len(ajson) - 2) + End If + End If + + json_from_table = ajson + +End Function + +Public Function json_from_table_zb(ByRef tbl() As Variant, ByRef array_label As String, ByVal force_array As Boolean, Optional strip_braces As Boolean) As String + + Dim ajson As String + Dim json As String + Dim r As Integer + Dim c As Integer + Dim needs_comma As Boolean + Dim needs_braces As Integer + + needs_comma = False + needs_braces = 0 + ajson = "" + + For r = 1 To UBound(tbl, 1) + For c = 0 To UBound(tbl, 2) + If tbl(r, c) <> "" Then + needs_braces = needs_braces + 1 + If needs_comma Then json = json & "," + needs_comma = True + If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then + json = json & Chr(34) & tbl(0, c) & Chr(34) & ":" & tbl(r, c) + Else + 'test if item is a json object + If Mid(tbl(r, c), 1, 1) = "{" Or Mid(tbl(r, c), 1, 1) = "[" Then + json = json & """" & tbl(0, c) & """" & ":" & tbl(r, c) + Else + json = json & Chr(34) & tbl(0, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34) + End If + End If + End If + Next c + If needs_braces > 0 Then json = "{" & json & "}" + needs_comma = False + needs_braces = 0 + If r > 1 Then + ajson = ajson & "," & json + Else + ajson = json + End If + json = "" + Next r + + 'if theres more the one record, include brackets for array + 'if an array_label is given give the array a key and the array become the value + 'then if the array is labeled with a key it should have braces unless specified otherwise + If r > 2 Or force_array Then + ajson = "[" & ajson & "]" + If array_label <> "" Then + ajson = """" & array_label & """:" & ajson + If Not strip_braces Then + ajson = "{" & ajson & "}" + End If + End If + Else + If strip_braces Then + ajson = Mid(ajson, 2, Len(ajson) - 2) + End If + End If + + json_from_table_zb = ajson + +End Function + +Public Function SHTp_get_block(point As Range) As Variant() + + SHTp_get_block = point.CurrentRegion + +End Function + +Sub frmListBoxHeader(ByRef hdr As MSForms.listbox, ByRef det As MSForms.listbox, ParamArray cols()) + + Dim i As Long + + hdr.ColumnCount = det.ColumnCount + hdr.ColumnWidths = det.ColumnWidths + + ' add header elements + hdr.clear + hdr.AddItem + For i = 0 To UBound(cols, 1) + hdr.list(0, i) = cols(i) + Next i + + ' make it pretty + 'body.ZOrder (1) + 'lbHEAD.ZOrder (0) + hdr.SpecialEffect = fmSpecialEffectFlat + 'hdr.BackColor = RGB(200, 200, 200) + 'hdr.Height = 15 + + ' align header to body (should be done last!) + hdr.width = det.width + hdr.Left = det.Left + hdr.Top = det.Top - (hdr.Height + 3) + +End Sub + +Public Function IntersectsWith(Range1 As Range, Range2 As Range) As Boolean + IntersectsWith = Not Application.Intersect(Range1, Range2) Is Nothing +End Function + + diff --git a/Master Template.xlsm_EXPORTS/build.frm b/Master Template.xlsm_EXPORTS/build.frm new file mode 100644 index 0000000..3affa42 --- /dev/null +++ b/Master Template.xlsm_EXPORTS/build.frm @@ -0,0 +1,39 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} build + Caption = "Change the Mix" + ClientHeight = 1590 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 10725 + OleObjectBlob = "build.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "build" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Public useval As Boolean + +Private Sub cmdCancel_Click() + useval = False + Me.Hide +End Sub + +Private Sub cmdOK_Click() + useval = True + Me.Hide +End Sub + +Public Sub Initialize(part As String, billTo As String, shipTo As String) + cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.Value + cbPart.Value = part + cbBill.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.Value + cbBill.Value = billTo + cbShip.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.Value + cbShip.Value = shipTo + + useval = False +End Sub diff --git a/Master Template.xlsm_EXPORTS/build.frx b/Master Template.xlsm_EXPORTS/build.frx new file mode 100644 index 0000000..614b17d Binary files /dev/null and b/Master Template.xlsm_EXPORTS/build.frx differ diff --git a/Master Template.xlsm_EXPORTS/changes.frm b/Master Template.xlsm_EXPORTS/changes.frm new file mode 100644 index 0000000..29bd6e6 --- /dev/null +++ b/Master Template.xlsm_EXPORTS/changes.frm @@ -0,0 +1,75 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} changes + Caption = "History" + ClientHeight = 7815 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 16710 + OleObjectBlob = "changes.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "changes" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Private X As Variant + +Private Sub UserForm_Activate() + tbPrint.Value = "" + + Dim fail As Boolean + X = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & shData.Cells(2, 5) & """}}", fail) + If fail Then + Unload Me + MsgBox ("No adjustments have been made.") + End + End If + Me.lbHist.list = X + Call Utils.frmListBoxHeader(Me.lbHEAD, Me.lbHist, "Modifier", "Owner", "When", "Tag", "Comment", "Sales", "id") +End Sub + +Private Sub cbCancel_Click() + Me.Hide +End Sub + +Private Sub cbUndo_Click() + Call Me.delete_selected +End Sub + +Private Sub lbHist_Change() + Dim i As Integer + + For i = 0 To Me.lbHist.ListCount - 1 + If Me.lbHist.Selected(i) Then + Me.tbPrint.Value = X(i, 7) + Exit Sub + End If + Next i +End Sub + +Sub delete_selected() + Dim logid As Integer + Dim i As Integer + Dim fail As Boolean + Dim proceed As Boolean + + If MsgBox("Permanently delete these changes?", vbYesNo) = vbNo Then + Exit Sub + End If + + For i = 0 To Me.lbHist.ListCount - 1 + If Me.lbHist.Selected(i) Then + Call handler.undo_changes(X(i, 6), fail) + If fail Then + MsgBox ("Undo did not work.") + Exit Sub + End If + End If + Next i + + shOrders.PivotTables("ptOrders").PivotCache.Refresh + + Me.lbHist.clear + Me.Hide +End Sub diff --git a/Master Template.xlsm_EXPORTS/changes.frx b/Master Template.xlsm_EXPORTS/changes.frx new file mode 100644 index 0000000..35e8278 Binary files /dev/null and b/Master Template.xlsm_EXPORTS/changes.frx differ diff --git a/Master Template.xlsm_EXPORTS/fpvt.frm b/Master Template.xlsm_EXPORTS/fpvt.frm new file mode 100644 index 0000000..0c4946f --- /dev/null +++ b/Master Template.xlsm_EXPORTS/fpvt.frm @@ -0,0 +1,559 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt + Caption = "Forecast Adjustment" + ClientHeight = 8490.001 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 8670.001 + OleObjectBlob = "fpvt.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "fpvt" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Private month() As Variant +Private adjust As Object +Private load_tb As Boolean +Private set_Price As Boolean +Private sp As Object + +Private bVol As Double +Private bVal As Double +Private bPrc As Double +Private pVol As Double +Private pVal As Double +Private pPrc As Double +Private aVol As Double +Private aVal As Double +Private aPrc As Double +Private fVol As Double +Private fVal As Double +Private fPrc As Double + +'===================================================================================================== +' Developers' backdoor to enter or exit debug mode: Ctrl-RightClick on the "Selected Scenario" +' label at the top of the form. Debug Mode shows the Pending Changes tab in the form, as well +' as all hidden sheets. +Private Sub Label62_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) + If Button = 2 And Shift = 2 Then + shConfig.Range("debug_mode") = Not shConfig.Range("debug_mode") + mp.Pages("pAPIDOC").Visible = shConfig.Range("debug_mode") + End If +End Sub +'===================================================================================================== + +Private Sub butAdjust_Click() + Dim fail As Boolean + Dim msg As String + + If tbAPI.text = "" Then msg = "No adjustments provided." + If cbTAG.text = "" Then msg = "No tag was selected." + If tbAPI.text = "" Then msg = "No adjustements are ready." + + If msg <> "" Then + MsgBox msg, vbOKOnly Or vbExclamation + Exit Sub + End If + + If Not handler.request_adjust(tbAPI.text, msg) Then + MsgBox msg, vbOKOnly Or vbExclamation, "Adjustment was not made due to error." + Exit Sub + End If + + Me.tbCOM = "" + Me.cbTAG.text = "" + + Me.Hide + + Set adjust = Nothing +End Sub + +Private Sub butCancel_Click() + Me.Hide +End Sub + +Private Sub cbGoSheet_Click() + shMonthView.Range("MonthComment").Value = "" + shMonthView.Range("MonthTag").Value = "" + shMonthView.Range("QtyPctChange").Value = 0 + shMonthView.Range("PricePctChange").Value = 0 + shMonthView.Visible = xlSheetVisible + shMonthView.Select + Me.Hide +End Sub + +Private Sub cbTAG_Change() + Dim j As Object + If tbAPI.text = "" Then tbAPI.text = "{}" + Set j = JsonConverter.ParseJson(tbAPI.text) + j("tag") = cbTAG.Value + tbAPI.text = JsonConverter.ConvertToJson(j) +End Sub + +Private Sub opEditPrice_Click() + opPlugVol.Visible = False + opPlugPrice.Visible = False +' opPlugPrice.Value = True +' opPlugVol.Value = False + + tbFcPrice.Enabled = True + tbFcPrice.BackColor = &H80000018 + tbFcVal.Enabled = False + tbFcVal.BackColor = &H80000005 + tbFcVol.Enabled = True + tbFcVol.BackColor = &H80000018 + + sbpv.Enabled = True + sbpp.Enabled = True + sbpd.Enabled = False + tbpv.Enabled = True + tbpp.Enabled = True + tbpd.Enabled = False +End Sub + +Private Sub opEditSales_Click() + opPlugVol.Visible = True + opPlugPrice.Visible = True + + tbFcPrice.Enabled = False + tbFcPrice.BackColor = &H80000005 + tbFcVal.Enabled = True + tbFcVal.BackColor = &H80000018 + tbFcVol.Enabled = False + tbFcVol.BackColor = &H80000005 + + sbpv.Enabled = False + sbpp.Enabled = False + sbpd.Enabled = True + tbpv.Enabled = False + tbpp.Enabled = False + tbpd.Enabled = True +End Sub + +Private Sub opPlugPrice_Click() + calc_val +End Sub + +Private Sub opPlugVol_Click() + calc_val +End Sub + +Private Sub sbpd_Change() + tbpd.Value = sbpd.Value +End Sub + +Private Sub sbpp_Change() + tbpp.Value = sbpp.Value +End Sub + +Private Sub sbpv_Change() + tbpv.Value = sbpv.Value +End Sub + +Private Sub tbCOM_Change() + If tbAPI.text = "" Then tbAPI.text = "{}" + Set adjust = JsonConverter.ParseJson(tbAPI.text) + adjust("message") = tbCOM.text + tbAPI.text = JsonConverter.ConvertToJson(adjust) +End Sub + +Private Sub tbFcPrice_Change() + If load_tb Then Exit Sub + set_Price = True + If opEditPrice Then calc_price + set_Price = False +End Sub + +Private Sub tbFcVal_Change() + If load_tb Then Exit Sub + If opEditSales Then calc_val +End Sub + +Private Sub tbFcVol_Change() + If load_tb Then Exit Sub + If opEditPrice Then calc_price +End Sub + +Private Sub tbpd_Change() + If load_tb Then Exit Sub + If Not VBA.IsNumeric(tbpd.Value) Then Exit Sub + tbFcVal = (bVal + pVal) * (1 + tbpd.Value / 100) +End Sub + +Private Sub tbpp_Change() + If load_tb Then Exit Sub + If Not VBA.IsNumeric(tbpd.Value) Then Exit Sub + tbFcPrice = (bPrc + pPrc) * (1 + tbpp.Value / 100) + Me.load_mbox_ann +End Sub + +Private Sub tbpv_Change() + If load_tb Then Exit Sub + If Not VBA.IsNumeric(tbpv.Value) Then Exit Sub + tbFcVol = (bVol + pVol) * (1 + tbpv.Value / 100) +End Sub + +Private Sub UserForm_Activate() + Me.Caption = "Forecast Adjust " & shConfig.Range("version").Value & " Loading..." + Me.mp.Visible = False + Me.fraExit.Visible = False + + Dim ok As Boolean + Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok) + Call Utils.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection") + + Me.Caption = "Forecast Adjust " & shConfig.Range("version").Value + + If Not ok Then + fpvt.Hide + Application.StatusBar = False + Exit Sub + End If + + '---show existing adjustment if there is one---- + pVol = 0 + pVal = 0 + pPrc = 0 + bVol = 0 + bVal = 0 + bPrc = 0 + aVol = 0 + aVal = 0 + aPrc = 0 + fVal = 0 + fVol = 0 + fPrc = 0 + Me.tbAPI.Value = "" + + If IsNull(sp("package")("totals")) Then + MsgBox "An unexpected error has occurred when retrieving the scenario.", vbOKOnly Or vbExclamation, "Error" + fpvt.Hide + Application.StatusBar = False + Exit Sub + End If + + Dim i As Long + For i = 1 To sp("package")("totals").Count + Select Case sp("package")("totals")(i)("order_season") + Case 2025 + Select Case Me.iter_def(sp("package")("totals")(i)("iter")) + Case "baseline" + bVol = bVol + sp("package")("totals")(i)("units") + bVal = bVal + sp("package")("totals")(i)("value_usd") + If bVol <> 0 Then bPrc = bVal / bVol + + Case "adjust" + pVol = pVol + sp("package")("totals")(i)("units") + pVal = pVal + sp("package")("totals")(i)("value_usd") + + Case "exclude" + + End Select + End Select + Next i + + fVol = bVol + pVol + fVal = bVal + pVal + If fVol = 0 Then + fPrc = 0 + Else + fPrc = fVal / fVol + End If + If (bVol + pVol) = 0 Then + pPrc = 0 + Else + If bVol = 0 Then + pPrc = 0 + Else + pPrc = (pVal + bVal) / (bVol + pVol) - bVal / bVol + End If + End If + If aVal <> 0 Then + MsgBox (aVal) + End If + Me.load_mbox_ann + + '---------------------------------------populate monthly------------------------------------------------------- + + '--parse json into variant array for loading-- + ReDim month(sp("package")("mpvt").Count + 1, 10) + + For i = 1 To sp("package")("mpvt").Count + month(i, 0) = sp("package")("mpvt")(i)("order_month") + month(i, 1) = sp("package")("mpvt")(i)("2024 qty") + month(i, 2) = sp("package")("mpvt")(i)("2025 base qty") + month(i, 3) = sp("package")("mpvt")(i)("2025 adj qty") + month(i, 4) = sp("package")("mpvt")(i)("2025 tot qty") + month(i, 5) = sp("package")("mpvt")(i)("2024 value_usd") + month(i, 6) = sp("package")("mpvt")(i)("2025 base value_usd") + month(i, 7) = sp("package")("mpvt")(i)("2025 adj value_usd") + month(i, 8) = sp("package")("mpvt")(i)("2025 tot value_usd") + If co_num(month(i, 2), 0) = 0 Then + month(i, 9) = "addmonth" + Else + month(i, 9) = "scale" + End If + Next i + + Me.crunch_array + + ReDim basket(sp("package")("basket").Count, 3) + basket(0, 0) = "part_descr" + basket(0, 1) = "bill_cust_descr" + basket(0, 2) = "ship_cust_descr" + basket(0, 3) = "mix" + + For i = 1 To UBound(basket, 1) + basket(i, 0) = sp("package")("basket")(i)("part_descr") + basket(i, 1) = sp("package")("basket")(i)("bill_cust_descr") + basket(i, 2) = sp("package")("basket")(i)("ship_cust_descr") + basket(i, 3) = sp("package")("basket")(i)("mix") + Next i + + '-------------load tags------------------------------- + cbTAG.list = shConfig.ListObjects("TAGS").DataBodyRange.Value + + '----------reset spinner buttons---------------------- + sbpv.Value = 0 + sbpp.Value = 0 + sbpd.Value = 0 + + Call handler.month_tosheet(month, basket) + Application.StatusBar = False + + Me.mp.Visible = True + Me.fraExit.Visible = True +End Sub + +Sub crunch_array() + + Dim i As Integer + + month(13, 1) = 0 + month(13, 2) = 0 + month(13, 3) = 0 + month(13, 4) = 0 + month(13, 5) = 0 + month(13, 6) = 0 + month(13, 7) = 0 + month(13, 8) = 0 + + For i = 1 To 12 + month(13, 1) = month(13, 1) + co_num(month(i, 1), 0) + month(13, 2) = month(13, 2) + co_num(month(i, 2), 0) + month(13, 3) = month(13, 3) + co_num(month(i, 3), 0) + month(13, 4) = month(13, 4) + co_num(month(i, 4), 0) + month(13, 5) = month(13, 5) + co_num(month(i, 5), 0) + month(13, 6) = month(13, 6) + co_num(month(i, 6), 0) + month(13, 7) = month(13, 7) + co_num(month(i, 7), 0) + month(13, 8) = month(13, 8) + co_num(month(i, 8), 0) + Next i + + ReDim mload(UBound(month, 1), 5) + For i = 0 To UBound(month, 1) + mload(i, 0) = month(i, 0) + mload(i, 1) = Format(month(i, 1), "#,###") + mload(i, 2) = Format(month(i, 4), "#,###") + mload(i, 3) = Format(month(i, 5), "#,###") + mload(i, 4) = Format(month(i, 8), "#,###") + Next i +End Sub + +Public Function rev_cust(cust As String) As String + If cust = "" Then + rev_cust = "" + Exit Function + End If + + If InStr(1, cust, " - ") <= 9 Then + rev_cust = trim(Mid(cust, 11, 100)) & " - " & trim(Left(cust, 8)) + Else + rev_cust = trim(Right(cust, 8)) & " - " & Mid(cust, 1, InStr(1, cust, " - ")) + End If + +End Function + +Sub load_mbox_ann() + + load_tb = True + + tbBaseVol = Format(bVol, "#,##0") + tbBaseVal = Format(bVal, "#,##0") + tbBasePrice = Format(bPrc, "0.00000") + + tbPadjVol = Format(pVol, "#,##0") + tbPadjVal = Format(pVal, "#,##0") + tbPadjPrice = Format(pPrc, "0.00000") + + tbFcVol = Format(fVol, "#,##0") + tbFcVal = Format(fVal, "#,##0") + If Not set_Price Then tbFcPrice = Format(fPrc, "0.00000") + + tbAdjVol = Format(aVol, "#,##0") + tbAdjVal = Format(aVal, "#,##0") + tbAdjPrice = Format(aPrc, "0.00000") + + load_tb = False +End Sub + +Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant + + If Not IsNumeric(one) Or IsNull(one) Then + co_num = two + Else + co_num = one + End If + +End Function + +Sub calc_val() + + Dim pchange As Double + + If IsNumeric(tbFcVal.Value) Then + 'get textbox value + fVal = tbFcVal.Value + 'do calculations + aVal = fVal - bVal - pVal + + '---------if volume adjustment method is selected, scale the volume up---------------------------------- + If opPlugVol Then + If (Round(pVal, 2) + Round(bVal, 2)) = 0 Then + pchange = 0 + If co_num(pVal, bVal) = 0 Then + MsgBox "Zero times any number is zero. Cannot scale to get to the target." + Else + fVol = fVal / (co_num(bVal, pVal) / co_num(bVol, pVol)) + End If + Else + pchange = fVal / (pVal + bVal) + fVol = (pVol + bVol) * pchange + End If + + Else + fVol = pVol + bVol + End If + If fVol = 0 Then + fPrc = 0 + Else + fPrc = fVal / fVol + End If + aVol = fVol - (bVol + pVol) + aPrc = fPrc - (bPrc + pPrc) + Else + aVol = fVol - bVol - pVol + aPrc = 0 + + End If + tbFcVal = Format(co_num(tbFcVal, 0), "#,##0") + + Me.load_mbox_ann + + 'build json + Set adjust = JsonConverter.ParseJson("{""scenario"":" & scenario & "}") + adjust("scenario")("version") = handler.plan + adjust("scenario")("iter") = handler.basis + adjust("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss") + adjust("user") = Application.UserName + adjust("source") = "adj" + adjust("message") = tbCOM.text + adjust("tag") = cbTAG.text + If opEditSales Then + If opPlugVol Then + adjust("type") = "scale_v" + adjust("amount") = aVal + adjust("qty") = aVol + Else + adjust("type") = "scale_p" + adjust("amount") = aVal + End If + Else + adjust("type") = "scale_vp" + adjust("qty") = aVol + adjust("amount") = aVal + End If + + 'print json + tbAPI = JsonConverter.ConvertToJson(adjust) +End Sub + +Sub calc_price() + fVol = co_num(tbFcVol.Value, 0) + fPrc = co_num(tbFcPrice.Value, 0) + 'calc + fVal = fPrc * fVol + aVal = fVal - bVal - pVal + aVol = fVol - (bVol + pVol) + + If (bVol + pVol) = 0 Then + aPrc = 0 + Else + 'aPrc = fVal / fVol - ((bVal + pVal) / (bVol + pVol)) + aPrc = fPrc - (bPrc + pPrc) + End If + 'End If + + Me.load_mbox_ann + + 'build json + Set adjust = JsonConverter.ParseJson("{""scenario"":" & scenario & "}") + adjust("scenario")("version") = handler.plan + adjust("scenario")("iter") = handler.basis + adjust("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss") + adjust("user") = Application.UserName + adjust("source") = "adj" + adjust("message") = tbCOM.text + adjust("tag") = cbTAG.text + adjust("version") = handler.plan + + If opEditSales Then + If opPlugVol Then + adjust("type") = "scale_v" + adjust("amount") = aVal + Else + adjust("type") = "scale_p" + adjust("amount") = aVal + End If + Else + If aVol = 0 Then + adjust("type") = "scale_p" + Else + adjust("type") = "scale_vp" + End If + adjust("qty") = aVol + adjust("amount") = aVal + End If + + 'print json + tbAPI = JsonConverter.ConvertToJson(adjust) +End Sub + +Function iter_def(ByVal iter As String) As String + + Dim i As Integer + + For i = 0 To UBound(handler.baseline) + If handler.baseline(i) = iter Then + iter_def = "baseline" + Exit Function + End If + Next i + + For i = 0 To UBound(handler.adjust) + If handler.adjust(i) = iter Then + iter_def = "adjust" + Exit Function + End If + Next i + + iter_def = "exclude" + +End Function + + + + diff --git a/Master Template.xlsm_EXPORTS/fpvt.frx b/Master Template.xlsm_EXPORTS/fpvt.frx new file mode 100644 index 0000000..1ac76e7 Binary files /dev/null and b/Master Template.xlsm_EXPORTS/fpvt.frx differ diff --git a/Master Template.xlsm_EXPORTS/handler.bas b/Master Template.xlsm_EXPORTS/handler.bas new file mode 100644 index 0000000..881cd1b --- /dev/null +++ b/Master Template.xlsm_EXPORTS/handler.bas @@ -0,0 +1,655 @@ +Attribute VB_Name = "handler" +Option Explicit + +Public sql As String +Public jsql As String +Public scenario As String +Public sc() As Variant +Public data() As String +Public agg() As String +Public showprice As Boolean +Public server As String +Public plan As String +Public basis() As Variant +Public baseline() As Variant +Public adjust() As Variant + + +Sub load_fpvt() + + Application.StatusBar = "retrieving selection data....." + + Dim i As Long + Dim s_tot As Object + + fpvt.lbSDET.list = handler.sc + + showprice = False + + For i = 0 To UBound(handler.sc, 1) + If handler.sc(i, 0) = "part_descr" Then + showprice = True + Exit For + End If + Next i + + + fpvt.Show + + + +End Sub + +Function scenario_package(doc As String, ByRef status As Boolean) As Object + + Dim req As New WinHttp.WinHttpRequest + Dim json As Object + Dim wr As String + + On Error GoTo errh + + With req + .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All + .Open "GET", server & "/scenario_package", True + .SetRequestHeader "Content-Type", "application/json" + .Send doc + Debug.Print "GET /scenario_package ("; + Dim t As Single + t = Timer + .WaitForResponse + wr = .ResponseText + Debug.Print Timer - t; "sec): "; Left(wr, 200) + End With + + Set json = JsonConverter.ParseJson(wr) + Set scenario_package = json + +errh: + If Err.Number <> 0 Then + status = False + MsgBox (Err.Description) + Set scenario_package = Nothing + Else + status = True + End If + +End Function + + +Sub pg_main_workset(catg As String, rep As String) + + Dim req As New WinHttp.WinHttpRequest + Dim wr As String + Dim json As Object + Dim doc As String + Dim res() As Variant + + doc = "{""scenario"":{""" & catg & """:""" & rep & """}}" + + Application.StatusBar = "Querying for " & rep & "'s pool of data..." + With req + .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All + .Open "GET", handler.server & "/get_pool", True + .SetRequestHeader "Content-Type", "application/json" + .Send doc + Debug.Print "GET /get_pool ("; + Dim t As Single + t = Timer + .WaitForResponse + wr = .ResponseText + Debug.Print Timer - t; "sec): "; Left(wr, 200) + End With + + If Mid(wr, 1, 1) <> "{" Then + MsgBox (wr) + Exit Sub + End If + + Application.StatusBar = "Parsing query results..." + Set json = JsonConverter.ParseJson(wr) + + If IsNull(json("x")) Then + MsgBox "No data found for " & rep & "." + Exit Sub + End If + + ReDim res(0, 34) + res(0, 0) = "bill_cust_descr" + res(0, 1) = "billto_group" + res(0, 2) = "ship_cust_descr" + res(0, 3) = "shipto_group" + res(0, 4) = "quota_rep_descr" + res(0, 5) = "director" + res(0, 6) = "segm" + res(0, 7) = "substance" + res(0, 8) = "chan" + res(0, 9) = "chansub" + res(0, 10) = "part_descr" + res(0, 11) = "part_group" + res(0, 12) = "branding" + res(0, 13) = "majg_descr" + res(0, 14) = "ming_descr" + res(0, 15) = "majs_descr" + res(0, 16) = "mins_descr" + res(0, 17) = "order_season" + res(0, 18) = "order_month" + res(0, 19) = "ship_season" + res(0, 20) = "ship_month" + res(0, 21) = "request_season" + res(0, 22) = "request_month" + res(0, 23) = "promo" + res(0, 24) = "value_loc" + res(0, 25) = "value_usd" + res(0, 26) = "cost_loc" + res(0, 27) = "cost_usd" + res(0, 28) = "units" + res(0, 29) = "version" + res(0, 30) = "iter" + res(0, 31) = "logid" + res(0, 32) = "tag" + res(0, 33) = "comment" + res(0, 34) = "pounds" + + shData.Cells.ClearContents + Call Utils.SHTp_DumpVar(res, shData.Name, 1, 1, False, True, True) + + Dim batchSize As Integer + batchSize = 1000 + Dim totalRows As Long + totalRows = json("x").Count + Dim jsonRow As Long + jsonRow = 1 + Dim sheetRow As Long + sheetRow = 2 + Dim arrayRow As Long + + ' While the JSON array still has rows, + ' 1. move the 1st one to a VBA 2-D array, deleting it from the JSON array. + ' 2. When 1000 have been copied, put the values onto the worksheet, and + ' empty the VBA array. + ' Splitting the JSON array into smaller batches when creating the VBA array + ' means there is less memory needed for the operation. + Do While json("x").Count > 0 + If jsonRow Mod batchSize = 1 Then + ReDim res(batchSize - 1, 34) + arrayRow = 0 + End If + res(arrayRow, 0) = json("x")(1)("bill_cust_descr") + res(arrayRow, 1) = json("x")(1)("billto_group") + res(arrayRow, 2) = json("x")(1)("ship_cust_descr") + res(arrayRow, 3) = json("x")(1)("shipto_group") + res(arrayRow, 4) = json("x")(1)("quota_rep_descr") + res(arrayRow, 5) = json("x")(1)("director") + res(arrayRow, 6) = json("x")(1)("segm") + res(arrayRow, 7) = json("x")(1)("substance") + res(arrayRow, 8) = json("x")(1)("chan") + res(arrayRow, 9) = json("x")(1)("chansub") + res(arrayRow, 10) = json("x")(1)("part_descr") + res(arrayRow, 11) = json("x")(1)("part_group") + res(arrayRow, 12) = json("x")(1)("branding") + res(arrayRow, 13) = json("x")(1)("majg_descr") + res(arrayRow, 14) = json("x")(1)("ming_descr") + res(arrayRow, 15) = json("x")(1)("majs_descr") + res(arrayRow, 16) = json("x")(1)("mins_descr") + res(arrayRow, 17) = json("x")(1)("order_season") + res(arrayRow, 18) = json("x")(1)("order_month") + res(arrayRow, 19) = json("x")(1)("ship_season") + res(arrayRow, 20) = json("x")(1)("ship_month") + res(arrayRow, 21) = json("x")(1)("request_season") + res(arrayRow, 22) = json("x")(1)("request_month") + res(arrayRow, 23) = json("x")(1)("promo") + res(arrayRow, 24) = json("x")(1)("value_loc") + res(arrayRow, 25) = json("x")(1)("value_usd") + res(arrayRow, 26) = json("x")(1)("cost_loc") + res(arrayRow, 27) = json("x")(1)("cost_usd") + res(arrayRow, 28) = json("x")(1)("units") + res(arrayRow, 29) = json("x")(1)("version") + res(arrayRow, 30) = json("x")(1)("iter") + res(arrayRow, 31) = json("x")(1)("logid") + res(arrayRow, 32) = json("x")(1)("tag") + res(arrayRow, 33) = json("x")(1)("comment") + res(arrayRow, 34) = json("x")(1)("pounds") + json("x").Remove 1 + arrayRow = arrayRow + 1 + If jsonRow Mod batchSize = 0 Or json("x").Count = 0 Then + Application.StatusBar = "Populating spreadsheet: " & Format(jsonRow, "#,##0") & " of " & Format(totalRows, "#,##0") & " rows..." + Call Utils.SHTp_DumpVar(res, shData.Name, sheetRow, 1, False, True, True) + sheetRow = sheetRow + batchSize + End If + jsonRow = jsonRow + 1 + Loop + + Set json = Nothing + Application.StatusBar = False +End Sub + +Sub pull_rep() + openf.Show +End Sub + + + +Function request_adjust(doc As String, ByRef msg As String) As Boolean + + Dim req As New WinHttp.WinHttpRequest + Dim json As Object + Dim wr As String + Dim i As Long + Dim j As Long + Dim str() As String + + request_adjust = False + + If doc = "" Then + msg = "No data was given to be processed." + Exit Function + End If + + 'update timestamp + Set json = JsonConverter.ParseJson(doc) + 'json("stamp") = Format(Now, "yyyy-mm-dd hh:mm:ss") + 'doc = JsonConverter.ConvertToJson(doc) + + server = shConfig.Range("server").Value + + With req + .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All + .Open "POST", server & "/" & json("type"), True + .SetRequestHeader "Content-Type", "application/json" + .Send doc + Debug.Print "GET /"; json("type"); " ("; + Dim t As Single + t = Timer + .WaitForResponse + wr = .ResponseText + Debug.Print Timer - t; "sec): "; Left(wr, 200) + End With + + If Mid(wr, 2, 5) = "error" Or _ + Mid(wr, 1, 6) = "" Or _ + Mid(wr, 1, 6) = " 0 Then + '--prior-- + If co_num(pkg(i, 1), 0) = 0 Then + .Cells(i + 1, 6) = 0 + Else + .Cells(i + 1, 6) = pkg(i, 5) / pkg(i, 1) + End If + + '--base-- + If co_num(pkg(i, 2), 0) = 0 Then + 'if there is no monthly base volume, + 'then use the prior price, if there was no prior price, + 'then inherit the average price for the year before current adjustments + If .Cells(i, 7) <> 0 Then + .Cells(i + 1, 7) = .Cells(i, 7) + Else + If pkg(13, 1) + pkg(13, 2) = 0 Then + .Cells(i + 1, 7) = 0 + Else + .Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2)) + End If + End If + Else + .Cells(i + 1, 7) = pkg(i, 6) / pkg(i, 2) + End If + + '--adjust-- + If (pkg(i, 3) + pkg(i, 2)) = 0 Or pkg(i, 2) = 0 Then + .Cells(i + 1, 8) = 0 + Else + .Cells(i + 1, 8) = (Round(pkg(i, 7), 10) + Round(pkg(i, 6), 10)) / (Round(pkg(i, 3), 10) + Round(pkg(i, 2), 10)) - (Round(pkg(i, 6), 10) / Round(pkg(i, 2), 10)) + End If + + '--current adjust-- + .Cells(i + 1, 9) = 0 + + '--forecast-- + If co_num(pkg(i, 4), 0) = 0 Then + 'if there is no monthly base volume, + 'then use the prior price, if there was no prior price, + 'then inherit the average price for the year before current adjustments + If .Cells(i, 10) <> 0 Then + .Cells(i + 1, 10) = .Cells(i, 10) + Else + If pkg(13, 1) + pkg(13, 2) = 0 Then + .Cells(i + 1, 10) = 0 + Else + .Cells(i + 1, 10) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2)) + End If + End If + Else + .Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4) + End If + + End If + + Next i + + 'scenario + .Range("R1:S1000").ClearContents + For i = 0 To UBound(handler.sc, 1) + .Cells(i + 1, 18) = handler.sc(i, 0) + .Cells(i + 1, 19) = handler.sc(i, 1) + Next i + + 'basket + .Range("U1:AC100000").ClearContents + Call Utils.SHTp_DumpVar(basket, .Name, 1, 21, False, False, True) + Call Utils.SHTp_DumpVar(basket, .Name, 1, 26, False, False, True) + shConfig.Range("rebuild").Value = 0 + shConfig.Range("show_basket").Value = 0 + shConfig.Range("new_part").Value = 0 + + shMonthView.LoadSheet + + End With + +End Sub + +Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant + + If one = "" Or IsNull(one) Then + co_num = two + Else + co_num = one + End If + +End Function + + +Function list_changes(doc As String, ByRef fail As Boolean) As Variant() + + Dim req As New WinHttp.WinHttpRequest + Dim json As Object + Dim wr As String + Dim i As Long + Dim j As Long + Dim res() As Variant + + If doc = "" Then + fail = True + Exit Function + End If + + server = shConfig.Range("server").Value + + With req + .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All + .Open "GET", server & "/list_changes", True + .SetRequestHeader "Content-Type", "application/json" + .Send doc + Debug.Print "GET /list_changes ("; + Dim t As Single + t = Timer + .WaitForResponse + wr = .ResponseText + Debug.Print Timer - t; "sec): "; Left(wr, 200) + End With + + Set json = JsonConverter.ParseJson(wr) + + If IsNull(json("x")) Then + fail = True + Exit Function + End If + + ReDim res(json("x").Count - 1, 7) + + For i = 0 To UBound(res, 1) + res(i, 0) = json("x")(i + 1)("user") + res(i, 1) = json("x")(i + 1)("quota_rep_descr") + res(i, 2) = json("x")(i + 1)("stamp") + res(i, 3) = json("x")(i + 1)("tag") + res(i, 4) = json("x")(i + 1)("comment") + res(i, 5) = json("x")(i + 1)("sales") + res(i, 6) = json("x")(i + 1)("id") + res(i, 7) = json("x")(i + 1)("doc") + Next i + + list_changes = res + +End Function + +Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant() + + Dim req As New WinHttp.WinHttpRequest + Dim json As Object + Dim wr As String + Dim i As Long + Dim j As Long + Dim res() As Variant + Dim doc As String + Dim ds As Worksheet + + doc = "{""logid"":" & logid & "}" + + server = handler.server + + With req + .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All + .Open "GET", server & "/undo_change", True + .SetRequestHeader "Content-Type", "application/json" + .Send doc + Debug.Print "GET /undo_change ("; + Dim t As Single + t = Timer + .WaitForResponse + wr = .ResponseText + Debug.Print Timer - t; "sec): "; Left(wr, 200) + End With + + Set json = JsonConverter.ParseJson(wr) + logid = json("x")(1)("id") + + '---------loop through and get a list of each row that needs deleted?----- + + j = 0 + For i = 1 To 100 + If shData.Cells(1, i) = "logid" Then + j = i + Exit For + End If + Next i + + If j = 0 Then + MsgBox ("Current data set is not tracking changes. Cannot isolate change locally.") + fail = True + Exit Function + End If + + i = 2 + With shData + While .Cells(i, 1) <> "" + If .Cells(i, j) = logid Then + .Rows(i).Delete + Else + i = i + 1 + End If + Wend + End With + +End Function + + +Sub history() + + changes.Show + +End Sub + +Function get_swap_fit(doc As String, ByRef fail As Boolean) As Variant() + + Dim req As New WinHttp.WinHttpRequest + Dim json As Object + Dim wr As String + Dim i As Integer + Dim j As Integer + Dim res() As Variant + + If doc = "" Then + fail = True + Exit Function + End If + + server = shConfig.Range("server").Value + + With req + .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All + .Open "GET", server & "/swap_fit", True + .SetRequestHeader "Content-Type", "application/json" + .Send doc + Debug.Print "GET /swap_fit ("; + Dim t As Single + t = Timer + .WaitForResponse + wr = .ResponseText + Debug.Print Timer - t; "sec): "; Left(wr, 200) + End With + + Set json = JsonConverter.ParseJson(wr) + + If IsNull(json("x")) Then + MsgBox ("No history.") + fail = True + Exit Function + End If + + ReDim res(json("x").Count - 1, 3) + + For i = 0 To UBound(res, 1) + res(i, 0) = json("x")(i + 1)("part") + res(i, 1) = json("x")(i + 1)("value_usd") + res(i, 2) = json("x")(i + 1)("swap") + res(i, 3) = json("x")(i + 1)("fit") + Next i + + get_swap_fit = res + +End Function + + + diff --git a/Master Template.xlsm_EXPORTS/openf.frm b/Master Template.xlsm_EXPORTS/openf.frm new file mode 100644 index 0000000..fe4676e --- /dev/null +++ b/Master Template.xlsm_EXPORTS/openf.frm @@ -0,0 +1,64 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} openf + Caption = "Open a Forecast" + ClientHeight = 2400 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 8220.001 + OleObjectBlob = "openf.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "openf" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Private Sub cbCancel_Click() + openf.Hide +End Sub + +Private Sub cbOK_Click() + If opDSM.Value Then + Call handler.pg_main_workset("quota_rep_descr", cbDSM.Value) + ElseIf opDirector.Value Then + Call handler.pg_main_workset("director", cbDirector.Value) + ElseIf opSegment.Value Then + Call handler.pg_main_workset("segm", cbSegment.Value) + End If + shOrders.PivotTables("ptOrders").PivotCache.Refresh + openf.Hide +End Sub + +Private Sub cbOK_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) + If Button = 2 And Shift = 2 Then + shConfig.Range("debug_mode") = Not shConfig.Range("debug_mode") + End If +End Sub + +Private Sub opDSM_Click() + cbDSM.Visible = True + cbDirector.Visible = False + cbSegment.Visible = False +End Sub + +Private Sub opDirector_Click() + cbDSM.Visible = False + cbDirector.Visible = True + cbSegment.Visible = False +End Sub + +Private Sub opSegment_Click() + cbDSM.Visible = False + cbDirector.Visible = False + cbSegment.Visible = True +End Sub + +Private Sub UserForm_Activate() + handler.server = shConfig.Range("server").Value + cbDSM.list = shSupportingData.ListObjects("DSM").DataBodyRange.Value + cbDirector.list = shConfig.ListObjects("DIRECTORS").DataBodyRange.Value + cbSegment.list = shConfig.ListObjects("SEGMENTS").DataBodyRange.Value +End Sub + + + diff --git a/Master Template.xlsm_EXPORTS/openf.frx b/Master Template.xlsm_EXPORTS/openf.frx new file mode 100644 index 0000000..675589f Binary files /dev/null and b/Master Template.xlsm_EXPORTS/openf.frx differ diff --git a/Master Template.xlsm_EXPORTS/part.frm b/Master Template.xlsm_EXPORTS/part.frm new file mode 100644 index 0000000..f73ae0c --- /dev/null +++ b/Master Template.xlsm_EXPORTS/part.frm @@ -0,0 +1,35 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} part + Caption = "Part Picker" + ClientHeight = 1335 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 9285.001 + OleObjectBlob = "part.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "part" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Public useval As Boolean + +Private Sub cmdCancel_Click() + useval = False + Me.Hide +End Sub + +Private Sub cmdOK_Click() + useval = True + Me.Hide +End Sub + +Private Sub UserForm_Activate() + useval = False + cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.Value +End Sub + + diff --git a/Master Template.xlsm_EXPORTS/part.frx b/Master Template.xlsm_EXPORTS/part.frx new file mode 100644 index 0000000..ab288a0 Binary files /dev/null and b/Master Template.xlsm_EXPORTS/part.frx differ diff --git a/Master Template.xlsm_EXPORTS/shConfig.cls b/Master Template.xlsm_EXPORTS/shConfig.cls new file mode 100644 index 0000000..5f89933 --- /dev/null +++ b/Master Template.xlsm_EXPORTS/shConfig.cls @@ -0,0 +1,31 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shConfig" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + +Private Sub Worksheet_Change(ByVal Target As Range) + If Intersect(Target, shConfig.Range("debug_mode")) Is Nothing Then Exit Sub + + If shConfig.Range("debug_mode").Value Then + shConfig.Visible = xlSheetVisible + 'shData.Visible = xlSheetVisible + shMonthView.Visible = xlSheetVisible + shMonthUpdate.Visible = xlSheetVisible + shSupportingData.Visible = xlSheetVisible + shWalk.Visible = xlSheetVisible + Else + shConfig.Visible = xlSheetVeryHidden + 'shData.Visible = xlSheetHidden + shMonthView.Visible = xlSheetHidden + shMonthUpdate.Visible = xlSheetVeryHidden + shSupportingData.Visible = xlSheetVeryHidden + shWalk.Visible = xlSheetVeryHidden + End If +End Sub + diff --git a/Master Template.xlsm_EXPORTS/shData.cls b/Master Template.xlsm_EXPORTS/shData.cls new file mode 100644 index 0000000..760b10c --- /dev/null +++ b/Master Template.xlsm_EXPORTS/shData.cls @@ -0,0 +1,9 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shData" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True diff --git a/Master Template.xlsm_EXPORTS/shHelp.cls b/Master Template.xlsm_EXPORTS/shHelp.cls new file mode 100644 index 0000000..940e153 --- /dev/null +++ b/Master Template.xlsm_EXPORTS/shHelp.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shHelp" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/Master Template.xlsm_EXPORTS/shMonthUpdate.cls b/Master Template.xlsm_EXPORTS/shMonthUpdate.cls new file mode 100644 index 0000000..fee51b7 --- /dev/null +++ b/Master Template.xlsm_EXPORTS/shMonthUpdate.cls @@ -0,0 +1,9 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shMonthUpdate" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True diff --git a/Master Template.xlsm_EXPORTS/shMonthView.cls b/Master Template.xlsm_EXPORTS/shMonthView.cls new file mode 100644 index 0000000..f8c58bd --- /dev/null +++ b/Master Template.xlsm_EXPORTS/shMonthView.cls @@ -0,0 +1,905 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shMonthView" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + +Private units() As Variant +Private price() As Variant +Private sales() As Variant +Private tunits() As Variant +Private tprice() As Variant +Private tsales() As Variant +Private busy As Boolean +Private vedit As String +Private adjust() As Object +Private jtext() As Variant +Private rollback As Boolean +Private scenario() As Variant +Private orig As Range +Private showbasket As Boolean +Private np As Object 'json dedicated to new part scenario +Private did_load_config As Boolean + +Public Sub MPP_Down() ' Handler for down-triangle on price percent change. + If newpart Then Exit Sub + + With shMonthView.Range("PricePctChange") + .Value = WorksheetFunction.Max(-0.1, .Value - 0.01) + End With + MPP_Change +End Sub + +Public Sub MPP_Up() ' Handler for up-triangle on price percent change. + If newpart Then Exit Sub + + With shMonthView.Range("PricePctChange") + .Value = WorksheetFunction.Min(0.1, .Value + 0.01) + End With + MPP_Change +End Sub + +Private Sub MPP_Change() + Dim i As Long + + Application.ScreenUpdating = False + + busy = True + + With shMonthView + For i = 1 To 12 + If .Range("PriceBaseline").Cells(i) > 0 Then + .Range("PriceNewAdj").Cells(i) = .Range("PriceBaseline").Cells(i) * .Range("PricePctChange") + End If + Next i + End With + Me.mvp_adj + + busy = False + + Application.ScreenUpdating = True +End Sub + + +Public Sub MPV_Down() ' Handler for down-triangle on qty percent change. + If newpart Then Exit Sub + + With shMonthView.Range("QtyPctChange") + .Value = WorksheetFunction.Max(-0.1, .Value - 0.01) + End With + MPV_Change +End Sub + +Public Sub MPV_Up() ' Handler for up-triangle on qty percent change. + If newpart Then Exit Sub + + With shMonthView.Range("QtyPctChange") + .Value = WorksheetFunction.Min(0.1, .Value + 0.01) + End With + MPV_Change +End Sub + +Private Sub MPV_Change() + Dim i As Long + + Application.ScreenUpdating = False + + busy = True + + With shMonthView + For i = 1 To 12 + If .Range("QtyBaseline").Cells(i) <> 0 Then + .Range("QtyNewAdj").Cells(i) = .Range("QtyBaseline").Cells(i) * .Range("QtyPctChange") + End If + Next i + End With + + busy = False + + Call Me.mvp_adj + + Application.ScreenUpdating = True +End Sub + +Public Sub ToggleVolumePrice() + shMonthView.Range("MonthAdjustVolume").Value = (shMonthView.Range("MonthAdjustVolume").Value <> True) + shMonthView.Range("MonthAdjustPrice").Value = Not shMonthView.Range("MonthAdjustVolume").Value +End Sub + +Private Sub Worksheet_Change(ByVal Target As Range) + '---this needs checked prior to busy check because % increase spinners are flagged as dumps + If Not did_load_config Then + Call handler.load_config + did_load_config = True + End If + + If busy Then Exit Sub + + If (IntersectsWith(Target, Range("units")) Or _ + IntersectsWith(Target, Range("price")) Or _ + IntersectsWith(Target, Range("sales"))) And _ + Target.Columns.Count > 1 _ + Then + MsgBox "You can only change one column at a time. Your change will be undone." + busy = True + Application.Undo + busy = False + Exit Sub + End If + + If IntersectsWith(Target, Range("QtyNewAdj")) Then Call Me.mvp_adj + If IntersectsWith(Target, Range("QtyFinal")) Then Call Me.mvp_set + If IntersectsWith(Target, Range("PriceNewAdj")) Then Call Me.mvp_adj + If IntersectsWith(Target, Range("PriceFinal")) Then Call Me.mvp_set + If IntersectsWith(Target, Range("SalesNewAdj")) Then Call Me.ms_adj + If IntersectsWith(Target, Range("SalesFinal")) Then Call Me.ms_set + + If IntersectsWith(Target, Range("basket")) And shConfig.Range("show_basket").Value = 1 Then + If RemoveEmptyBasketLines Then ' Lines were removed + GetEditBasket shMonthView.Range("basket").Resize(1, 1) ' Don't "touch" the mix column, so as to rescale all rows proportionally to 100% total. + Else + GetEditBasket Target + End If + End If +End Sub + +Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) + If IntersectsWith(Target, Union(Range("basket_new_item"), Range("basket"))) And shConfig.Range("show_basket").Value = 1 Then + Cancel = True + Call Me.basket_pick(Target) + Target.Select + End If +End Sub + + +Sub picker_shortcut() + If IntersectsWith(Selection, Range("basket")) And shConfig.Range("show_basket").Value = 1 Then + Call Me.basket_pick(Selection) + End If + +End Sub + +Public Function rev_cust(cust As String) As String + + If cust = "" Then + rev_cust = "" + Exit Function + End If + + If InStr(1, cust, " - ") <= 9 Then + rev_cust = trim(Mid(cust, 11, 100)) & " - " & trim(Left(cust, 8)) + Else + rev_cust = trim(Right(cust, 8)) & " - " & Mid(cust, 1, InStr(1, cust, " - ")) + End If + +End Function + +Sub mvp_set() + + Dim i As Integer + GetSheet + + For i = 1 To 12 + If units(i, 5) = "" Then units(i, 5) = 0 + If price(i, 5) = "" Then price(i, 5) = 0 + units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3)) + price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3)) + sales(i, 5) = units(i, 5) * price(i, 5) + If units(i, 4) = 0 And price(i, 4) = 0 Then + sales(i, 4) = 0 + Else + sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3)) + End If + Next i + + CrunchArray + BuildJson + SetSheet + + +End Sub + +Sub mvp_adj() + + Dim i As Integer + GetSheet + + For i = 1 To 12 + If units(i, 4) = "" Then units(i, 4) = 0 + If price(i, 4) = "" Then price(i, 4) = 0 + units(i, 5) = units(i, 4) + (units(i, 2) + units(i, 3)) + price(i, 5) = price(i, 4) + (price(i, 2) + price(i, 3)) + sales(i, 5) = units(i, 5) * price(i, 5) + If units(i, 4) = 0 And price(i, 4) = 0 Then + sales(i, 4) = 0 + Else + sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3)) + End If + Next i + + CrunchArray + BuildJson + SetSheet + + +End Sub + +Sub ms_set() + +On Error GoTo errh + + Dim i As Integer + GetSheet + + For i = 1 To 12 + If sales(i, 5) = "" Then sales(i, 5) = 0 + If Round(sales(i, 5) - (sales(i, 2) + sales(i, 3)), 2) <> Round(sales(i, 4), 2) Then + sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3)) + + If shMonthView.Range("MonthAdjustVolume") Then + If co_num(price(i, 5), 0) = 0 Then + MsgBox "Volume cannot be automatically adjusted because price is 0. Your change will be undone.", vbOKOnly Or vbExclamation, "Division by zero" + busy = True + Application.Undo + busy = False + Exit Sub + End If + units(i, 5) = sales(i, 5) / price(i, 5) + units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3)) + + ElseIf shMonthView.Range("MonthAdjustPrice") Then + If co_num(units(i, 5), 0) = 0 Then + MsgBox "Price cannot be automatically adjusted because volume is 0. Your change will be undone.", vbOKOnly Or vbExclamation, "Division by zero" + busy = True + Application.Undo + busy = False + Exit Sub + End If + price(i, 5) = sales(i, 5) / units(i, 5) + price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3)) + + Else + MsgBox "Neither Volume or Price was selected. Your change will be undone", vbOKOnly Or vbExclamation, "Bad Setup" + busy = True + Application.Undo + busy = False + Exit Sub + End If + End If + Next i + + CrunchArray + BuildJson + SetSheet + +errh: + If Err.Number <> 0 Then rollback = True + + +End Sub + +Sub ms_adj() + + Dim i As Integer + GetSheet + + For i = 1 To 12 + If sales(i, 4) = "" Then sales(i, 4) = 0 + If Round(sales(i, 5), 6) <> Round(sales(i, 2) + sales(i, 3) + sales(i, 4), 6) Then + sales(i, 5) = sales(i, 4) + sales(i, 2) + sales(i, 3) + + If shMonthView.Range("MonthAdjustVolume") Then + If co_num(price(i, 5), 0) = 0 Then + MsgBox "Volume cannot be automatically adjusted because price is 0. Your change will be undone.", vbOKOnly Or vbExclamation, "Division by zero" + busy = True + Application.Undo + busy = False + Exit Sub + End If + units(i, 5) = sales(i, 5) / price(i, 5) + units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3)) + + ElseIf shMonthView.Range("MonthAdjustPrice") Then + If co_num(units(i, 5), 0) = 0 Then + MsgBox "Price cannot be automatically adjusted because volume is 0. Your change will be undone.", vbOKOnly Or vbExclamation, "Division by zero" + busy = True + Application.Undo + busy = False + Exit Sub + End If + price(i, 5) = sales(i, 5) / units(i, 5) + price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3)) + + Else + MsgBox "Neither Volume or Price was selected. Your change will be undone", vbOKOnly Or vbExclamation, "Bad Setup" + busy = True + Application.Undo + busy = False + Exit Sub + End If + End If + Next i + + CrunchArray + BuildJson + SetSheet + +End Sub + + +Private Sub GetSheet() + With shMonthView + units = .Range("units") + price = .Range("price") + sales = .Range("sales") + tunits = .Range("tunits") + tprice = .Range("tprice") + tsales = .Range("tsales") + ReDim adjust(12) + End With +End Sub + +Private Function basejson() As Object + Set basejson = JsonConverter.ParseJson(shMonthUpdate.Range("P1").FormulaR1C1) +End Function + +Private Sub SetSheet() + + Dim i As Integer + + busy = True + + With shMonthView + .Range("units") = units + .Range("price") = price + .Range("sales") = sales + .Range("tunits").FormulaR1C1 = tunits + .Range("tprice").FormulaR1C1 = tprice + .Range("tsales").FormulaR1C1 = tsales + .Range("scenario").ClearContents + + Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("R1")), .Name, .Range("scenario").row, .Range("scenario").Column, False, False, False) + '.Range("B32:Q5000").ClearContents + End With + + If Me.newpart Then + shMonthUpdate.Range("P2:P13").ClearContents + shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np) + Else + For i = 1 To 12 + shMonthUpdate.Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) + Next i + End If + + busy = False + +End Sub + +Public Sub LoadSheet() + + units = shMonthUpdate.Range("A2:E13").FormulaR1C1 + price = shMonthUpdate.Range("F2:J13").FormulaR1C1 + sales = shMonthUpdate.Range("K2:O13").FormulaR1C1 + scenario = shMonthUpdate.Range("R1:S13").FormulaR1C1 + tunits = shMonthView.Range("tunits") + tprice = shMonthView.Range("tprice") + tsales = shMonthView.Range("tsales") + 'reset basket + shMonthUpdate.Range("U1:X10000").ClearContents + Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("Z1")), shMonthUpdate.Name, 1, 21, False, False, False) + ReDim adjust(12) + CrunchArray + SetSheet + Call Me.print_basket + did_load_config = False + +End Sub + +Private Sub BuildJson() + + Dim i As Long + Dim j As Long + Dim pos As Long + Dim o As Object + Dim m As Object + Dim list As Object + + load_config + + ReDim adjust(12) + + If Me.newpart Then + Set np = JsonConverter.ParseJson(JsonConverter.ConvertToJson(basejson())) + np("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") + np("user") = Application.UserName + np("scenario")("version") = handler.plan + Set np("scenario")("iter") = JsonConverter.ParseJson("[""copy"",""plan""]") + np("source") = "adj" + np("type") = "new_basket" + np("tag") = shMonthView.Range("MonthTag").Value + Set m = JsonConverter.ParseJson("{}") + End If + + For pos = 1 To 12 + If Me.newpart Then + If sales(pos, 5) <> 0 Then + Set o = JsonConverter.ParseJson("{}") + o("amount") = sales(pos, 5) + o("qty") = units(pos, 5) + Set m(shMonthView.Range("OrderMonths").Cells(pos, 1).Value) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(o)) + End If + Else + 'if something is changing + If Round(units(pos, 4), 2) <> 0 Or (Round(price(pos, 4), 8) <> 0 And Round(units(pos, 5), 2) <> 0) Then + Set adjust(pos) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(basejson())) + 'if there is no existing volume on the target month but units are being added + If units(pos, 2) + units(pos, 3) = 0 And units(pos, 4) <> 0 Then + 'add month + adjust(pos)("type") = "addmonth_vp" + adjust(pos)("month") = shMonthView.Range("OrderMonths").Cells(pos, 1) + adjust(pos)("qty") = units(pos, 4) + adjust(pos)("amount") = sales(pos, 4) + Else + 'scale the existing volume(price) on the target month + If Round(price(pos, 4), 8) <> 0 Then + If Round(units(pos, 4), 2) <> 0 Then + adjust(pos)("type") = "scale_vp" + Else + adjust(pos)("type") = "scale_p" + End If + Else + 'if the target price is the same as average and a month is being added + adjust(pos)("type") = "scale_v" + End If + adjust(pos)("qty") = units(pos, 4) + adjust(pos)("amount") = sales(pos, 4) + '------------add this in to only scale a particular month-------------------- + adjust(pos)("scenario")("order_month") = shMonthView.Range("OrderMonths").Cells(pos, 1) + End If + adjust(pos)("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") + adjust(pos)("user") = Application.UserName + adjust(pos)("scenario")("version") = handler.plan + adjust(pos)("scenario")("iter") = handler.basis + adjust(pos)("source") = "adj" + End If + End If + Next pos + + If Me.newpart Then + Set np("months") = JsonConverter.ParseJson(JsonConverter.ConvertToJson(m)) + np("newpart") = shMonthView.Range("basket").Cells(1, 1).Value + 'get the basket from the sheet + Dim basket() As Variant + basket = shMonthUpdate.Range("U1").CurrentRegion.Value + Set m = JsonConverter.ParseJson(Utils.json_from_table(basket, "basket", False)) + If UBound(basket, 1) <= 2 Then + Set np("basket") = JsonConverter.ParseJson("[" & Utils.json_from_table(basket, "basket", False) & "]") + Else + Set np("basket") = m("basket") + End If + End If + + If Me.newpart Then + shMonthUpdate.Range("P2:P13").ClearContents + shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np) + Else + For i = 1 To 12 + shMonthUpdate.Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) + Next i + End If + +End Sub + +Private Sub CrunchArray() + + Dim i As Integer + Dim j As Integer + + For i = 1 To 5 + tunits(1, i) = 0 + tprice(1, i) = 0 + tsales(1, i) = 0 + Next i + + For i = 1 To 12 + For j = 1 To 5 + tunits(1, j) = tunits(1, j) + units(i, j) + tsales(1, j) = tsales(1, j) + sales(i, j) + Next j + Next i + + 'prior + If tunits(1, 1) = 0 Then + tprice(1, 1) = 0 + Else + tprice(1, 1) = tsales(1, 1) / tunits(1, 1) + End If + 'base + If tunits(1, 2) = 0 Then + tprice(1, 2) = 0 + Else + tprice(1, 2) = tsales(1, 2) / tunits(1, 2) + End If + 'forecast + If tunits(1, 5) <> 0 Then + tprice(1, 5) = tsales(1, 5) / tunits(1, 5) + Else + tprice(1, 5) = 0 + End If + 'adjust + If (tunits(1, 2) + tunits(1, 3)) = 0 Then + tprice(1, 3) = 0 + Else + tprice(1, 3) = (tsales(1, 2) + tsales(1, 3)) / (tunits(1, 2) + tunits(1, 3)) - tprice(1, 2) + End If + 'current adjust + tprice(1, 4) = tprice(1, 5) - (tprice(1, 2) + tprice(1, 3)) + + +End Sub + +Sub Cancel() + + shOrders.Select + +End Sub + +Sub reset() + + LoadSheet + +End Sub + +Sub switch_basket() + shConfig.Range("show_basket").Value = 1 - shConfig.Range("show_basket").Value + Call Me.print_basket +End Sub + +Sub print_basket() + + If shConfig.Range("show_basket").Value = 0 Then + busy = True + shMonthView.Range("basket").ClearContents + busy = False + Exit Sub + End If + + Dim i As Long + Dim basket() As Variant + basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1")) + + busy = True + + shMonthView.Range("basket").ClearContents + For i = 2 To UBound(basket, 1) + shMonthView.Range("basket").Resize(1, 1).Offset(i - 2, 0).Value = basket(i, 1) + shMonthView.Range("basket").Resize(1, 1).Offset(i - 2, 4).Value = basket(i, 2) + shMonthView.Range("basket").Resize(1, 1).Offset(i - 2, 10).Value = basket(i, 3) + shMonthView.Range("basket").Resize(1, 1).Offset(i - 2, 15).Value = basket(i, 4) + Next i + + busy = False + +End Sub + + +Sub basket_pick(ByRef Target As Range) + Dim i As Long + With shMonthView + build.Initialize .Cells(Target.row, 2), rev_cust(.Cells(Target.row, 6)), rev_cust(.Cells(Target.row, 12)) + build.Show + + If build.useval Then + busy = True + + .Cells(Target.row + i, 2) = build.cbPart.Value + .Cells(Target.row + i, 6) = rev_cust(build.cbBill.Value) + .Cells(Target.row + i, 12) = rev_cust(build.cbShip.Value) + busy = False + GetEditBasket Selection + + End If + End With + Target.Select +End Sub + +Private Function RemoveEmptyBasketLines() As Boolean + If busy Then Exit Function + busy = True + + RemoveEmptyBasketLines = False + Application.ScreenUpdating = False + + Dim lastRow As Long + lastRow = shMonthView.UsedRange.row + shMonthView.UsedRange.Rows.Count - 1 + + Dim i As Long + For i = lastRow To shMonthView.Range("basket").row Step -1 + If WorksheetFunction.CountA(shMonthView.Cells(i, 1).EntireRow) = 0 Then + shMonthView.Cells(i, 1).EntireRow.Delete + RemoveEmptyBasketLines = True + End If + Next + + Application.ScreenUpdating = True + + busy = False +End Function + +Private Sub GetEditBasket(touchedCells As Range) + Dim i As Long + Dim mix As Double + Dim touch_mix As Double + Dim untouched As Long + Dim touch() As Boolean + Dim basket() As Variant + + ReDim basket(0, 3) + + i = WorksheetFunction.CountA(Range("basket").Resize(, 1)) + If i > 0 Then + + ReDim basket(i - 1, 3) + ReDim touch(i - 1) + untouched = i + + busy = True + + With shMonthView.Range("basket") + mix = 0 + For i = 1 To .Rows.Count + basket(i - 1, 0) = .Cells(i, 1) + basket(i - 1, 1) = .Cells(i, 5) + basket(i - 1, 2) = .Cells(i, 11) + basket(i - 1, 3) = .Cells(i, 16) * 1 + mix = mix + basket(i - 1, 3) + If IntersectsWith(touchedCells, .Cells(i, 16)) Then + touch_mix = touch_mix + basket(i - 1, 3) + touch(i - 1) = True + untouched = untouched - 1 + End If + Next + + 'evaluate mix changes, force to 100, and update the sheet + For i = 0 To UBound(basket, 1) + If Not touch(i) Then + If mix = touch_mix Then + basket(i, 3) = (1 - mix) / untouched + Else + basket(i, 3) = basket(i, 3) + basket(i, 3) * (1 - mix) / (mix - touch_mix) + End If + .Cells(i + 1, 16) = basket(i, 3) + End If + Next i + + End With + + busy = False + + shMonthUpdate.Range("U2:X5000").ClearContents + Call Utils.SHTp_DumpVar(basket, shMonthUpdate.Name, 2, 21, False, False, True) + + If Me.newpart Then + BuildJson + End If + End If + +End Sub + + +Sub post_adjust() + Dim i As Long + Dim msg As String + + If Me.newpart Then + If WorksheetFunction.CountA(shMonthView.Range("basket").Resize(, 1)) = 0 Then + msg = "At least one row needs to be entered in the lower table. Use the New Business button or double-click in the blue row of the empty table." + End If + + If Abs(WorksheetFunction.Sum(shMonthView.Range("basket").Resize(, 1).Offset(0, 15)) - 1#) > 0.000001 Then + msg = "The mix column in the lower table does not add up to 100%. Change (or even just retype) one, and the rest will adjust" + End If + + If WorksheetFunction.CountIf(shMonthView.Range("SalesFinal"), 0) = 12 And WorksheetFunction.CountIf(shMonthView.Range("SalesNewAdj"), 0) = 12 Then + msg = "At least one month needs to have forecast data entered." + End If + Else + If WorksheetFunction.CountA(shMonthUpdate.Range("P2:P13")) = 0 Then msg = "Make sure at least one month has Final values for Volume, Price, and Sales." + End If + + If IsEmpty(shMonthView.Range("MonthTag").Value) Then msg = "You need to specify a tag for this update." + + If msg <> "" Then + MsgBox msg, vbOKOnly Or vbExclamation + Exit Sub + End If + + Dim adjust As Object + Dim jdoc As String + + If Me.newpart Then + Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(2, 16)) + adjust("message") = shMonthView.Range("MonthComment").Value + adjust("tag") = shMonthView.Range("MonthTag").Value + jdoc = JsonConverter.ConvertToJson(adjust) + If Not handler.request_adjust(jdoc, msg) Then + MsgBox msg, vbOKOnly Or vbCritical, "Adjustment was not made." + Exit Sub + End If + Else + Dim allMsg As String + For i = 2 To 13 + If shMonthUpdate.Cells(i, 16) <> "" Then + Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(i, 16)) + adjust("message") = shMonthView.Range("MonthComment").Value + adjust("tag") = shMonthView.Range("MonthTag").Value + jdoc = JsonConverter.ConvertToJson(adjust) + If Not handler.request_adjust(jdoc, msg) Then + Dim period As String + period = Format(i - 1, "00") & " - " & Format(DateSerial(2000, (i - 1) + 5, 1), "mmm") + allMsg = IIf(allMsg = "", "", vbNewLine) & period & ": " & msg + End If + End If + Next i + + If allMsg <> "" Then MsgBox allMsg, vbOKOnly Or vbCritical, "Problems Loading Adjustments" + End If + + shOrders.Select + +End Sub + +Sub build_new() + + shConfig.Range("rebuild").Value = 1 + Dim i As Long + Dim j As Long + Dim basket() As Variant + Dim m() As Variant + + busy = True + + m = shMonthUpdate.Range("A2:O13").FormulaR1C1 + + For i = 1 To UBound(m, 1) + For j = 1 To UBound(m, 2) + m(i, j) = 0 + Next j + Next i + + shMonthUpdate.Range("A2:O13") = m + + shMonthUpdate.Range("U2:X1000").ClearContents + shMonthUpdate.Range("Z2:AC1000").ClearContents + shMonthUpdate.Range("R2:S1000").ClearContents + LoadSheet + + basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1")) +' shMonthView.Cells(32, 2) = basket(1, 1) +' shMonthView.Cells(32, 6) = basket(1, 2) +' shMonthView.Cells(32, 12) = basket(1, 3) +' shMonthView.Cells(32, 17) = basket(1, 4) + Call Me.print_basket + + busy = False + +End Sub + +Sub new_part() + + 'keep customer mix + 'add in new part number + 'retain to _month + 'set new part flag + + Dim cust() As String + Dim i As Long + + '---------build customer mix------------------------------------------------------------------- + + cust = Utils.SHTp_Get(shMonthUpdate.Name, 1, 27, True) + If Not Utils.TBLp_Aggregate(cust, True, True, True, Array(0, 1), Array("S", "S"), Array(2)) Then + MsgBox ("Error building customer mix.") + End If + + '--------inquire for new part to join with cust mix-------------------------------------------- + + part.Show + + If Not part.useval Then + Exit Sub + End If + + busy = True + + With shMonthView.Range("basket") + .ClearContents + For i = 1 To UBound(cust, 2) + .Cells(i, 1) = part.cbPart.Value + .Cells(i, 5) = cust(0, i) + .Cells(i, 11) = cust(1, i) + .Cells(i, 16) = CDbl(cust(2, i)) + Next i + End With + + shConfig.Range("new_part").Value = 1 + + '------copy revised basket to _month storage--------------------------------------------------- + + With shMonthView.Range("basket") + i = WorksheetFunction.CountA(.Resize(, 1)) + If i = 0 Then Exit Sub + + ReDim basket(i - 1, 3) + + For i = 1 To .Rows.Count + basket(i - 1, 0) = .Cells(i, 1) + basket(i - 1, 1) = .Cells(i, 5) + basket(i - 1, 2) = .Cells(i, 11) + basket(i - 1, 3) = .Cells(i, 16) * 1 + Next + End With + + shMonthUpdate.Range("U2:AC100000").ClearContents + Call Utils.SHTp_DumpVar(basket, shMonthUpdate.Name, 2, 21, False, False, True) + Call Utils.SHTp_DumpVar(basket, shMonthUpdate.Name, 2, 26, False, False, True) + + '------reset volume to copy base to forecsat and clear base------------------------------------ + + units = shMonthUpdate.Range("A2:E13").FormulaR1C1 + price = shMonthUpdate.Range("F2:J13").FormulaR1C1 + sales = shMonthUpdate.Range("K2:O13").FormulaR1C1 + tunits = shMonthView.Range("tunits") + tprice = shMonthView.Range("tprice") + tsales = shMonthView.Range("tsales") + ReDim adjust(12) + For i = 1 To 12 + 'volume + units(i, 5) = 0 'units(i, 2) + units(i, 4) = 0 'units(i, 2) + units(i, 1) = 0 + units(i, 2) = 0 + units(i, 3) = 0 + 'sales + sales(i, 5) = 0 'sales(i, 2) + sales(i, 4) = 0 'sales(i, 2) + sales(i, 1) = 0 + sales(i, 2) = 0 + sales(i, 3) = 0 + 'price + price(i, 5) = 0 'price(i, 2) + price(i, 4) = 0 'price(i, 2) + price(i, 1) = 0 + price(i, 2) = 0 + price(i, 3) = 0 + Next i + CrunchArray + BuildJson + SetSheet + + '-------------push revised arrays back to _month, not revertable------------------------------- + + shMonthUpdate.Range("A2:E13") = units + shMonthUpdate.Range("F2:J13") = price + shMonthUpdate.Range("K2:o13") = sales + + + 'force basket to show to demonstrate the part was changed + shConfig.Range("show_basket").Value = 1 + Call Me.print_basket + busy = False + + End Sub + +Function newpart() As Boolean + newpart = shConfig.Range("new_part").Value = 1 +End Function + +Private Sub Worksheet_Deactivate() + Forecasting.shMonthView.Visible = IIf(shConfig.Range("debug_mode").Value, xlSheetVisible, xlSheetHidden) +End Sub diff --git a/Master Template.xlsm_EXPORTS/shOrders.cls b/Master Template.xlsm_EXPORTS/shOrders.cls new file mode 100644 index 0000000..d301ae0 --- /dev/null +++ b/Master Template.xlsm_EXPORTS/shOrders.cls @@ -0,0 +1,114 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shOrders" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + +Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) + Dim pt As PivotTable + Set pt = ActiveSheet.PivotTables("ptOrders") + + Dim intersec As Range + Set intersec = Intersect(Target, pt.DataBodyRange) + + If intersec Is Nothing Then + Exit Sub + ElseIf intersec.address <> Target.address Then + Exit Sub + End If + + Cancel = True + + Dim i As Long + Dim j As Long + Dim k As Long + + Dim ri As PivotItemList + Dim ci As PivotItemList + Dim df As Object + Dim rd As Object + Dim cd As Object + Dim dd As Object + + Dim pf As PivotField + Dim pi As PivotItem + + Set ri = Target.Cells.PivotCell.RowItems + Set ci = Target.Cells.PivotCell.ColumnItems + Set df = Target.Cells.PivotCell.DataField + + Set rd = Target.Cells.PivotTable.RowFields + Set cd = Target.Cells.PivotTable.ColumnFields + + ReDim handler.sc(ri.Count, 1) + + handler.sql = "" + handler.jsql = "" + + For i = 1 To ri.Count + If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND " + If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & "," + handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'" + jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """" + handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name + handler.sc(i - 1, 1) = ri(i).Name + Next i + + scenario = "{" & handler.jsql & "}" + + Call handler.load_config + Call handler.load_fpvt + +End Sub + +Function piv_pos(list As Object, target_pos As Long) As Long + + Dim i As Long + + For i = 1 To list.Count + If list(i).Position = target_pos Then + piv_pos = i + Exit Function + End If + Next i + 'should not get to this point + +End Function + +Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer + + Dim i As Integer + + For i = 1 To pt.PivotFields.Count + If pt.PivotFields(i).Name = field_name Then + piv_fld_index = i + Exit Function + End If + Next i + +End Function + +Function escape_json(ByVal text As String) As String + + text = Replace(text, "'", "''") + text = Replace(text, """", "\""") + If text = "(blank)" Then text = "" + escape_json = text + +End Function + +Function escape_sql(ByVal text As String) As String + + text = Replace(text, "'", "''") + text = Replace(text, """", """""") + If text = "(blank)" Then text = "" + escape_sql = text + +End Function + + diff --git a/Master Template.xlsm_EXPORTS/shSupportingData.cls b/Master Template.xlsm_EXPORTS/shSupportingData.cls new file mode 100644 index 0000000..7ff049e --- /dev/null +++ b/Master Template.xlsm_EXPORTS/shSupportingData.cls @@ -0,0 +1,9 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shSupportingData" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True diff --git a/Master Template.xlsm_EXPORTS/shWalk.cls b/Master Template.xlsm_EXPORTS/shWalk.cls new file mode 100644 index 0000000..1f5e1da --- /dev/null +++ b/Master Template.xlsm_EXPORTS/shWalk.cls @@ -0,0 +1,114 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shWalk" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +'Option Explicit +' +'Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) +' Dim pt As PivotTable +' Set pt = ActiveSheet.PivotTables("ptWalk") +' Dim intersec As Range +' Set intersec = Intersect(Target, pt.DataBodyRange) +' +' If intersec Is Nothing Then +' Exit Sub +' ElseIf intersec.address <> Target.address Then +' Exit Sub +' End If +' +' Cancel = True +' +' Dim i As Long +' Dim j As Long +' Dim k As Long +' +' Dim ri As PivotItemList +' Dim ci As PivotItemList +' Dim df As Object +' Dim rd As Object +' Dim cd As Object +' Dim dd As Object +' +' Dim pf As PivotField +' Dim pi As PivotItem +' +' Set ri = Target.Cells.PivotCell.RowItems +' Set ci = Target.Cells.PivotCell.ColumnItems +' Set df = Target.Cells.PivotCell.DataField +' +' Set rd = Target.Cells.PivotTable.RowFields +' Set cd = Target.Cells.PivotTable.ColumnFields +' +' ReDim handler.sc(ri.Count, 1) +' +' handler.sql = "" +' handler.jsql = "" +' +' For i = 1 To ri.Count +' If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND " +' If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & "," +' handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'" +' jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """" +' handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name +' handler.sc(i - 1, 1) = ri(i).Name +' Next i +' +' scenario = "{" & handler.jsql & "}" +' +' Call handler.load_config +' Call handler.load_fpvt +' +'End Sub +' +'Function piv_pos(list As Object, target_pos As Long) As Long +' +' Dim i As Long +' +' For i = 1 To list.Count +' If list(i).Position = target_pos Then +' piv_pos = i +' Exit Function +' End If +' Next i +' 'should not get to this point +' +'End Function +' +'Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer +' +' Dim i As Integer +' +' For i = 1 To pt.PivotFields.Count +' If pt.PivotFields(i).Name = field_name Then +' piv_fld_index = i +' Exit Function +' End If +' Next i +' +'End Function +' +'Function escape_json(ByVal text As String) As String +' +' text = Replace(text, "'", "''") +' text = Replace(text, """", "\""") +' If text = "(blank)" Then text = "" +' escape_json = text +' +'End Function +' +'Function escape_sql(ByVal text As String) As String +' +' text = Replace(text, "'", "''") +' text = Replace(text, """", """""") +' If text = "(blank)" Then text = "" +' escape_sql = text +' +'End Function +' +' +