diff --git a/VBA/JsonConverter.bas b/VBA/JsonConverter.bas new file mode 100644 index 0000000..f9dc6c1 --- /dev/null +++ b/VBA/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/VBA/TheBigOne.cls b/VBA/TheBigOne.cls new file mode 100644 index 0000000..cb811a7 --- /dev/null +++ b/VBA/TheBigOne.cls @@ -0,0 +1,2730 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "TheBigOne" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False + +Option Explicit + +Private ADOo_con() As ADODB.Connection +Private ADOo_rs() As ADODB.Recordset +Public ADOo_errstring As String + +Public Enum ADOinterface + MicrosoftJetOLEDB4 = 0 + MicrosoftACEOLEDB12 = 1 + SqlServer = 2 + SQLServerNativeClient = 3 + SQLServerNativeClient10 = 4 + OracleODBC = 5 + OracleOLEDB = 6 + TextFile = 7 + ISeries = 8 + PostgreSQLODBC = 9 +End Enum + +Public Enum SQLsyntax + Db2 = 0 + SqlServer = 1 + PostgreSQL = 2 +End Enum + + + + +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, Me.PAp_2DGetIntegerArray(0, groupnum_type_sumnum), Me.PAp_2DGetStringArray(1, groupnum_type_sumnum), headers) Then + TBLp_Aggregate = False + Exit Function + End If + End If + + If Not TBLp_Roll(tbl, Me.PAp_2DGetIntegerArray(0, groupnum_type_sumnum), Me.PAp_2DGetIntegerArray(2, groupnum_type_sumnum), headers) Then + TBLp_Aggregate = False + Exit Function + End If + + + If del_unused Then + keep = Me.PAp_2DGetMultIntegerArray(Me.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 Me.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) + Me.ADOo_errstring = Err.Description + End If + + TBLp_BubbleSortAsc = True + + +End Function + +Function TBLp_KeyBubbleSortAsc(ByRef tbl() As String, ByRef sortflds() As Integer, 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_KeyAscSwapFlag(tbl, i, j, sortflds) Then + Call ROWp_Swap(tbl, i, j) + Else + If Me.ADOo_errstring <> "" Then + TBLp_KeyBubbleSortAsc = False + Exit Function + End If + End If + Next j + Next i + +errh: + If Err.Number <> 0 Then + MsgBox ("Error at TBLP_keyBubbleSortAsc." & vbCrLf & Err.Description) + Me.ADOo_errstring = Err.Description + End If + + TBLp_KeyBubbleSortAsc = True + + +End Function + +Sub TBLp_BubbleSortDescend(ByRef tbl() As String, ByRef sortflds() As Integer, ByRef typeflds() As String, ByRef headers As Boolean) + + '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_DescendSwapFlag(tbl, i, j, sortflds, typeflds) Then + Call ROWp_Swap(tbl, i, j) + End If + Next j + Next i + +End Sub + + +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 + Me.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 = Me.MISCe_CompareString(CStr(tbl(KeyFld(i), row1)), CStr(tbl(KeyFld(i), row2))) + Case "N" + compare = Me.MISCe_CompareDouble(CDbl(tbl(KeyFld(i), row1)), CDbl(tbl(KeyFld(i), row2))) + Case "D" + compare = Me.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) + Me.ADOo_errstring = Err.Description + Exit Function + End If + +End Function + +Function ROWe_KeyAscSwapFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer) As Boolean + 'only returns true if greater than + +On Error GoTo errh + Dim i As Integer + Dim compare As Integer + Dim key1 As String + Dim key2 As String + + For i = 0 To UBound(KeyFld) + key1 = key1 & tbl(KeyFld(i), row1) + key2 = key2 & tbl(KeyFld(i), row2) + Next i + + compare = Me.MISCe_CompareString(key1, key2) + + Select Case compare + Case -1 + ROWe_KeyAscSwapFlag = True + Exit Function + Case 1 + ROWe_KeyAscSwapFlag = False + Exit Function + End Select + + +errh: + If Err.Number <> 0 Then + MsgBox ("Error at ROWe_keyAscSwapFlag." & vbCrLf & Err.Description) + Me.ADOo_errstring = Err.Description + Exit Function + End If + +End Function + +Function ROWe_DescendSwapFlag(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 + + Dim i As Integer + Dim compare As Integer + + For i = 0 To UBound(KeyFld) + Select Case TypeFld(i) + Case "S" + compare = Me.MISCe_CompareString(CStr(tbl(KeyFld(i), row1)), CStr(tbl(KeyFld(i), row2))) + Case "N" + compare = Me.MISCe_CompareDouble(CDbl(tbl(KeyFld(i), row1)), CDbl(tbl(KeyFld(i), row2))) + Case "D" + compare = Me.MISCe_CompareDate(CDate(tbl(KeyFld(i), row1)), CDate(tbl(KeyFld(i), row2))) + End Select + Select Case compare + Case 1 + ROWe_DescendSwapFlag = True + Exit Function + Case -1 + ROWe_DescendSwapFlag = False + Exit Function + End Select + Next i + +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_Dump(ByRef tbl() As String, ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef clear As Boolean, ByRef transpose As Boolean, ParamArray NumFields()) + + Dim sh As Worksheet + Set sh = Sheets(sheet) + + If clear Then sh.Cells.clear + If transpose Then Call Me.ARRAYp_Transpose(tbl) + + sh.Range(sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1), col + UBound(tbl, 2)).address).FormulaR1C1 = tbl + + On Error GoTo errhndl + + If UBound(NumFields()) <> -1 Then + Dim i As Integer + i = 0 + For i = 0 To UBound(NumFields()) + Call sh.Columns(NumFields(i) + 1).TextToColumns + Next i + End If + +errhndl: + If Err.Number <> 0 Then MsgBox ("Error in dumping to sheet" & vbCrLf & Err.Description) + + +End Sub + +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 Me.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 + +Sub ARRAYp_Transpose(ByRef a() As String) + + Dim s() As String + 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 + + a = s + +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 + + +Public Sub TBLp_FilterSingle(ByRef table() As String, ByRef column As Long, ByVal Filter As String, ByVal Equals As Boolean) + + Dim i As Long + Dim j As Long + Dim m As Long + + j = LBound(table, 2) + i = LBound(table, 2) + 1 + While i <= UBound(table, 2) + If (table(column, i) = Filter) = Equals Then + j = j + 1 + m = LBound(table, 1) + While m <= UBound(table, 1) + table(m, j) = table(m, i) + m = m + 1 + Wend + End If + i = i + 1 + Wend + + ReDim Preserve table(LBound(table, 1) To UBound(table, 1), LBound(table, 2) To j) + +End Sub + +Sub TBLp_AddEmptyCol(ByRef table() As String) + + Dim i As Long + Dim j As Long + Dim temp() As String + ReDim temp(UBound(table, 1) + 1, UBound(table, 2)) + i = 0 + While i <= UBound(table, 1) + j = 0 + While j <= UBound(table, 2) + temp(i, j) = table(i, j) + j = j + 1 + Wend + i = i + 1 + Wend + + table() = temp() + + + +End Sub + +Function SQLp_RollingMonthList(ByRef mmmyy As String, ByRef outformat As String, ByRef monthcount As Integer) As String + + + Dim cy As String + Dim cmn As Integer + Dim mlist As String + + Dim i As Integer + + cmn = Format(DateValue(Left(mmmyy, 3) & "-01-" & Right(mmmyy, 2)), "m") + cy = Right(mmmyy, 2) + + For i = 0 To monthcount - 1 + If i <> 0 Then mlist = mlist & "," + mlist = mlist & "'" & UCase(Format(DateValue(cmn & "-01-" & cy), outformat)) & "'" + cmn = cmn - 1 + If cmn = 0 Then + cmn = 12 + cy = Format(CInt(cy) - 1, "00") + End If + Next i + SQLp_RollingMonthList = mlist + + +End Function + +Sub TBLp_DeleteCols(ByRef tbl() As String, ByRef column() As Integer) + + Dim temp() As String + ReDim temp(UBound(tbl, 1) - (UBound(column()) + 1), UBound(tbl, 2)) + Dim i As Long + Dim j As Long + Dim m As Long + Dim k As Long + Dim ok As Boolean + + m = -1 + i = 0 + While i <= UBound(tbl, 1) + k = 0 + ok = True + Do While k <= UBound(column()) + If i = column(k) Then + ok = False + Exit Do + End If + k = k + 1 + Loop + If ok = True Then + m = m + 1 + j = 0 + While j <= UBound(tbl, 2) + temp(m, j) = tbl(i, j) + j = j + 1 + Wend + End If + i = i + 1 + Wend + + tbl() = temp() +End Sub + + + +Public Function ADOp_OpenCon(ByRef con As Integer, Optional ByVal value As ADOinterface, Optional ConnectTo As String, Optional IntgrtdSec As Boolean, Optional UserName As String, Optional Password As String, Optional textconfigs As String) As Boolean + +On Error GoTo ConnectionProblem + + Dim itype As String + Dim interface As String + Dim stype As String + Dim source As String + Dim properties As String + Dim cs As String + + If ADOo_con(con) Is Nothing Then + Set ADOo_con(con) = New ADODB.Connection + End If + 'if the connection is not open the set the provider if it is supplied + If ADOo_con(con).State = 0 Then + Select Case value + Case 0 + interface = "Microsoft.Jet.OLEDB.4.0" + itype = "Provider=" + source = ConnectTo + stype = ";Data Source=" + If IntgrtdSec Then + properties = ";User ID=admin" + properties = properties & ";Password=" + Else + properties = ";User ID=" & UserName + properties = properties & ";Password=" & Password + End If + Case 1 + interface = "Microsoft.ACE.OLEDB.12.0" + itype = "Provider=" + source = ConnectTo + stype = ";Data Source=" + If IntgrtdSec Then + properties = ";Persist Security Info = False" + Else + properties = ";Jet OLEDB:Database Password=" & Password + End If + Case 2 + interface = "SQLOLEDB" + itype = "Provider=" + source = ConnectTo + stype = ";Data Source=" + If IntgrtdSec Then + properties = ";Integrated Security=SSPI" + Else + properties = ";User ID=" & UserName + properties = properties & ";Password=" & Password + End If + Case 3 + interface = "SQLNCLI" + itype = "Provider=" + source = ConnectTo + stype = ";Server=" + If IntgrtdSec Then + properties = ";Trusted_Connection=yes" + Else + properties = ";Uid=" & UserName + properties = properties & ";Pwd=" & Password + End If + Case 4 + interface = "SQLNCLI10" + itype = "Provider=" + source = ConnectTo + stype = ";Server=" + If IntgrtdSec Then + properties = ";Trusted_Connection=yes" + Else + properties = ";Uid=" & UserName + properties = properties & ";Pwd=" & Password + End If + Case 5 + interface = "{Microsoft ODBC for Oracle}" + itype = "Driver=" + source = ConnectTo + stype = ";Server=" + properties = ";Uid=" & UserName + properties = properties & ";Pwd=" & Password + Case 6 + interface = "OraOLEDB.Oracle" + itype = "Provider=" + source = ConnectTo + stype = ";Data Source=" + If IntgrtdSec Then + properties = ";OSAuthent=1" + Else + properties = ";User ID=" & UserName + properties = properties & ";Password=" & Password + End If + Case 7 + interface = "Microsoft.Jet.OLEDB.4.0" + itype = "Provider=" + source = ConnectTo + stype = ";Data Source=" + properties = properties & ";" & textconfigs + 'text;HDR=yes;FMT=Delimited as example + Case 8 + interface = "{iSeries Access ODBC Driver}" + itype = "Driver=" + source = ConnectTo + stype = ";System=" + properties = ";Uid=" & UserName + properties = properties & ";Pwd=" & Password + Case 9 + interface = "{PostgreSQL Unicode(x64)}" + itype = "Driver=" + source = ConnectTo + stype = ";Server=" + properties = ";Uid=" & UserName + properties = properties & ";Pwd=" & Password + properties = properties & ";" & textconfigs + + End Select + + cs = itype & interface & stype & source & properties + ADOo_con(con).Open (cs) + + End If + + +ConnectionProblem: + If Err.Number <> 0 Then + ADOo_errstring = "Error Number:" & Err.Number & " -" & Err.Description + ADOp_OpenCon = False + Else + ADOo_errstring = "" + ADOp_OpenCon = True + End If + +'this path is only used if there are no connection strings available +noconnectionstring: + +End Function + +Private Sub Class_Initialize() + + ReDim ADOo_con(9) + ReDim ADOo_rs(9) + +End Sub + +Public Function ADOp_MoveRecords(ByRef con_from As Integer, ByRef con_to As Integer, ByRef from_sql As String, ByRef to_table As String, ByRef trim As Boolean) As Boolean + +On Error GoTo err_inactive + + Dim i As Long + Dim rc As Long + +'---------------------------Make sure connections are good to go------------------------------------------------------ + + If ADOo_con(con_from) Is Nothing Then Set ADOo_con(con_from) = New ADODB.Connection + If ADOo_con(con_to) Is Nothing Then Set ADOo_con(con_to) = New ADODB.Connection + + If ADOo_con(con_from).State = 0 Then + ADOo_errstring = "'From' source not connected in MoveRecords operation" + ADOp_MoveRecords = False + Exit Function + End If + + If ADOo_con(con_to).State = 0 Then + ADOo_errstring = "'To' source not connected in MoveRecords operation" + ADOp_MoveRecords = False + Exit Function + End If + + + +'-------------Start by opening a record set on the source location statement----------------------------- + + ADOo_con(con_from).CommandTimeout = 600 + Set ADOo_rs(con_from) = ADOo_con(con_from).Execute(from_sql) + +On Error GoTo err_active + +'---------------get first recordset that has >0 column count-------------------- + + If ADOo_rs(con_from).Fields.Count = 0 Then + Do Until ADOo_rs(con_from).Fields.Count <> 0 + Set ADOo_rs(con_from) = ADOo_rs(con_from).NextRecordset() + If ADOo_rs(con_from) Is Nothing Then Exit Do + Loop + + If ADOo_rs(con_from) Is Nothing Then + ADOo_errstring = "SQL did not return any results in MoveRecords Finction" + ADOp_MoveRecords = False + Exit Function + End If + End If + + + +'---------------Open up destination table---------------------------------- + + If ADOo_rs(con_to) Is Nothing Then + Set ADOo_rs(con_to) = New ADODB.Recordset + End If + + If ADOo_rs(con_to).State = 1 Then + ADOo_rs(con_to).Close + End If + + Call ADOo_rs(con_to).Open(to_table, ADOo_con(con_to), adOpenDynamic, adLockPessimistic) + +'-------------Make sure number of fields same in both record sets-------------------- + + If ADOo_rs(con_to).Fields.Count <> ADOo_rs(con_from).Fields.Count Then + ADOo_errstring = "Field count in MoveRecords function not equal" + ADOp_MoveRecords = False + Exit Function + End If + +'--------------Start movement------------------------- + + ADOo_con(con_to).BeginTrans + + + + While ADOo_rs(con_from).EOF = False + rc = rc + 1 + ADOo_rs(con_to).AddNew + For i = 0 To ADOo_rs(con_from).Fields.Count - 1 + If IsNull(ADOo_rs(con_from).Fields(i)) Then + ADOo_rs(con_to).Fields(i) = "" + Else + If trim Then + ADOo_rs(con_to).Fields(i) = LTrim(RTrim(ADOo_rs(con_from).Fields(i))) + Else + ADOo_rs(con_to).Fields(i) = ADOo_rs(con_from).Fields(i) + End If + End If + Next i + ADOo_rs(con_to).Update + ADOo_rs(con_from).MoveNext + Wend + + ADOo_con(con_to).CommitTrans + +'---------------- close connections------------------ + + ADOo_rs(con_to).Close + ADOo_rs(con_from).Close + +'--------------error handling--------------------------- + +err_inactive: + If Err.Number <> 0 Then + ADOo_errstring = ADOo_errstring & vbCrLf & Err.Description + ADOp_MoveRecords = False + If ADOo_rs(con_to).State <> 0 Then ADOo_rs(con_to).Close + If ADOo_rs(con_from).State <> 0 Then ADOo_rs(con_from).Close + Exit Function + Else + ADOp_MoveRecords = True + Exit Function + End If + +err_active: + If Err.Number <> 0 Then + ADOo_errstring = ADOo_errstring & vbCrLf & Err.Description & " at field =" & ADOo_rs(con_from).Fields(i).Name & " record " & rc + ADOp_MoveRecords = False + ADOo_con(con_to).RollbackTrans + ADOo_rs(con_to).Close + ADOo_rs(con_from).Close + Else + ADOp_MoveRecords = True + End If + +End Function + +Public Function ADOp_SelectS(ByRef con As Integer, ByVal sql As String, ByVal trim As Boolean, Optional ApproxSixe As Long, Optional InclHeaders As Boolean, Optional ByVal value As ADOinterface, Optional ConnectTo As String, Optional IntgrtdSec As Boolean, Optional UserName As String, Optional Password As String, Optional textconfigs As String) As String() + + On Error GoTo errflag + + Dim rs As ADODB.Recordset + Dim x() As String + + If ADOo_con(con) Is Nothing Then Set ADOo_con(con) = New ADODB.Connection + + If ADOo_con(con).State = 0 Then + If Not Me.ADOp_OpenCon(con, value, ConnectTo, IntgrtdSec, UserName, Password, textconfigs) Then + GoTo conerr + End If + End If + + ADOo_con(con).CommandTimeout = 3600 + Set ADOo_rs(con) = ADOo_con(con).Execute(sql) + ADOp_SelectS = ADOp_ExtractRecordsetS(con, trim, ApproxSixe, InclHeaders) + If ADOo_rs(con).State <> 0 Then ADOo_rs(con).Close + Exit Function + +conerr: + If Me.ADOo_errstring <> "" Then + ReDim x(0, 0) + x(0, 0) = "Error" + ADOp_SelectS = x + Exit Function + End If + +errflag: + + If Err.Number <> 0 Then + ReDim x(0, 0) + x(0, 0) = "Error" & Err.Number & vbCrLf & Err.Description + Me.ADOo_errstring = "Error: " & Err.Number & vbCrLf & Err.Description + ADOp_SelectS = x + End If + +End Function + +Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Boolean, Optional ByVal Size As Long, Optional headers As Boolean) As String() + + Dim i As Long + Dim j As Long + + On Error GoTo err_active + + 'if no size is provided, dim to one million + If Size = 0 Then Size = 1000000 + + 'size table + Dim table() As String + + If ADOo_rs(con).Fields.Count = 0 Then + Do Until ADOo_rs(con).Fields.Count <> 0 + Set ADOo_rs(con) = ADOo_rs(con).NextRecordset() + If ADOo_rs(con) Is Nothing Then Exit Do + Loop + + If ADOo_rs(con) Is Nothing Then + ReDim table(0, 0) + ADOp_ExtractRecordsetS = table + Exit Function + Else + ReDim table(ADOo_rs(con).Fields.Count - 1, Size) + End If + Else + ReDim table(ADOo_rs(con).Fields.Count - 1, Size) + End If + + 'populate headers if requested + If headers Then + i = 0 + While i <= UBound(table, 1) + table(i, 0) = ADOo_rs(con).Fields(i).Name + i = i + 1 + Wend + End If + + + 'populate array + If headers Then + i = 1 + Else + i = 0 + End If + + While ADOo_rs(con).EOF = False + j = 0 + While j <= (UBound(table, 1)) + If IsNull(ADOo_rs(con).Fields(j)) Then + table(j, i) = "" + Else + On Error Resume Next + If trim Then + table(j, i) = LTrim(RTrim(ADOo_rs(con).Fields(j))) + Else + table(j, i) = ADOo_rs(con).Fields(j) + End If + If Err.Number <> 0 Then table(j, i) = "Error:" & Err.Number + On Error GoTo err_active + End If + j = j + 1 + Wend + i = i + 1 + ADOo_rs(con).MoveNext + Wend + + If i = 0 Then i = 1 + ReDim Preserve table(UBound(table, 1), i - 1) + + +err_active: + If Err.Number <> 0 Then + ADOo_errstring = ADOo_errstring & vbCrLf & Err.Description & " at field =" & ADOo_rs(con).Fields(j).Name & " record " & i + ReDim table(0, 0) + table(0, 0) = ADOo_errstring + ADOp_ExtractRecordsetS = table + ADOo_rs(con).Close + Else + ADOp_ExtractRecordsetS = table + End If + +End Function + + + +Public Function TBLp_JoinTbls(ByRef tbl1() As String, ByRef tbl2() As String, ByRef headers As Boolean, ByRef NeedsSort As Boolean, ByRef dupfactor As Integer, ParamArray flds()) As String() + + + On Error GoTo errpath + '3 arrays + 'the first 2 arrays are the joining fields + 'the next array is what fields to attach to table1 + Dim t() As String + Dim i As Long + Dim j As Long + Dim k As Long + Dim copyrow As Long + Dim toprow As Long + Dim found As Boolean + Dim ntbl() As String + Dim hr As Integer + Dim ntrow As Long + + hr = 0 + If headers Then hr = 1 + + ReDim ntbl(UBound(tbl1, 1) + UBound(flds(2)) + 1, UBound(tbl1, 2) * dupfactor) + + + t = Me.PAp_2DGetStringArray(0, flds) + For i = 0 To UBound(t) + t(i) = "S" + Next i + + If NeedsSort Then Call Me.TBLp_KeyBubbleSortAsc(tbl2, Me.PAp_2DGetIntegerArray(1, flds), True) + + For i = 0 To UBound(tbl1, 2) + 'If i = 6516 Then MsgBox ("x") + For j = 0 To UBound(t) + t(j) = tbl1(flds(0)(j), i) + Next j + copyrow = Me.ROWe_FindOnSorted(tbl2, toprow, found, Me.PAp_2DGetIntegerArray(1, flds), t) + 'copy both sets of rows to new table + If found Then + For k = copyrow To toprow + Call ROWp_TableJoinCopy2ToNew(tbl1, tbl2, ntbl, Me.PAp_2DGetIntegerArray(2, flds), i, k, ntrow) + Next k + Else + Call ROWp_TableJoinCopy1ToNew(tbl1, ntbl, i, ntrow) + End If + Next i + + 'copy headers + If headers Then + Call ROWp_TableJoinCopy2ToNew(tbl1, tbl2, ntbl, Me.PAp_2DGetIntegerArray(2, flds), 0, 0, 0) + End If + + ReDim Preserve ntbl(UBound(ntbl, 1), ntrow - 1) + +errpath: + If Err.Number <> 0 Then + ADOo_errstring = ADOo_errstring & "Error in TLBp_JoinTbls" & vbCrLf & Err.Description & vbCrLf + ReDim ntbl(0, 0) + ntbl(0, 0) = ADOo_errstring + End If + TBLp_JoinTbls = ntbl + +End Function + +Private Sub ROWp_TableJoinCopy2ToNew(ByRef tbl1() As String, ByRef tbl2() As String, ByRef ntbl() As String, ByRef tbl2flds() As Integer, ByRef tbl1row As Long, ByRef tbl2row As Long, ByRef newrow As Long) + + Dim i As Integer + Dim j As Integer + + For i = 0 To UBound(tbl1, 1) + ntbl(i, newrow) = tbl1(i, tbl1row) + Next i + + For i = 0 To UBound(tbl2flds) + ntbl(UBound(tbl1, 1) + 1 + i, newrow) = tbl2(tbl2flds(i), tbl2row) + Next i + + newrow = newrow + 1 + +End Sub + +Private Sub ROWp_TableJoinCopy1ToNew(ByRef tbl1() As String, ByRef ntbl() As String, ByRef tbl1row As Long, ByRef newrow As Long) + + Dim i As Integer + + For i = 0 To UBound(tbl1, 1) + ntbl(i, newrow) = tbl1(i, tbl1row) + Next i + + newrow = newrow + 1 + + +End Sub + + + + + +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_3DGetStringArray(ByRef index As Integer, ParamArray pa()) As String() + + +On Error GoTo errh + 'when the parameter array gets passed into this functon as another paramtere array, an unnecessary dimension has been added + Dim str() As String + Dim i As Long + Dim j As Long + ReDim str(UBound(pa(0)(index), 1), UBound(pa(0)(index), 2)) + + For i = 0 To UBound(str, 2) + For j = 0 To UBound(str, 1) + str(j, i) = pa(0)(index)(j, i) + Next j + Next i + + +errh: + If Err.Number <> 0 Then + ADOo_errstring = ADOo_errstring & "Error at PAp_3DGetStringArray" & vbCrLf & Err.Description & vbCrLf + ReDim str(0, 0) + str(0, 0) = ADOo_errstring + End If + + PAp_3DGetStringArray = str + +End Function + +Function PAp_2DGetVariantArray(ByRef index As Integer, ParamArray pa()) As Variant() + + Dim str() As Variant + 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 + PA_2DGetVariantArray = str + + +End Function + +Function PAp_2DGetLongArray(ByRef index As Integer, ParamArray pa()) As Long() + + Dim str() As Long + 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 + PA_2DGetLongArray = 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 ARRAYp_MakeString(ParamArray items()) As String() + + Dim x() As String + Dim i As Integer + ReDim x(UBound(items)) + + For i = 0 To UBound(items()) + x(i) = items(i) + Next i + + ARRAYp_MakeString = 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_MaxInt(ByRef base As Integer, ByRef compare As Integer) As Integer + + If compare < base Then + MISCe_MaxInt = base + Exit Function + End If + + If compare = base Then + MISCe_MaxInt = compare + Exit Function + End If + + If compare > base Then + MISCe_MaxInt = compare + 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 ROWe_FindOnSorted(ByRef tbl() As String, ByRef Range As Long, ByRef match As Boolean, ParamArray fldsvals()) As Long + + On Error GoTo errpath + 'has to be a lexicographically sorted table otherwise this evaluaiton will not be the same as the sort evaluaiton + 'flds has a field number and the value to get + 'returns the low point and modifies the range parameter to reflect the high point + Dim maxrow As Long + Dim minrow As Long + Dim currow As Long + Dim curkey As String + Dim basekey As String + Dim i As Long + Dim j As Long + Dim found As Boolean + + + For i = 0 To UBound(fldsvals(1)) + curkey = curkey & fldsvals(1)(i) + Next i + + maxrow = UBound(tbl, 2) + currow = UBound(tbl, 2) \ 2 + minrow = 0 + + Do + Select Case Me.MISCe_CompareString(ROWp_CreateKey(tbl, Me.PAp_2DGetIntegerArray(0, fldsvals), currow), curkey) + Case -1 + maxrow = currow + currow = (currow - minrow) \ 2 + minrow + 'minrow stays same + 'if the spread is 10 or less just loop through due to '\' errors + If maxrow - minrow <= 10 Then + currow = minrow + Do Until Me.MISCe_CompareString(ROWp_CreateKey(tbl, Me.PAp_2DGetIntegerArray(0, fldsvals), currow), curkey) = 0 + currow = currow + 1 + If currow > maxrow Then + match = False + ROWe_FindOnSorted = 0 + Exit Function + End If + Loop + End If + Case 0 + 'check both directions for duplicates + If currow < UBound(tbl, 2) Then + i = currow + 1 + Do Until Me.MISCe_CompareString(ROWp_CreateKey(tbl, Me.PAp_2DGetIntegerArray(0, fldsvals), i), curkey) <> 0 + i = i + 1 + If i > UBound(tbl, 2) Then + Exit Do + End If + Loop + i = i - 1 + Else + i = currow + End If + + If currow > 0 Then + j = currow - 1 + Do Until Me.MISCe_CompareString(ROWp_CreateKey(tbl, Me.PAp_2DGetIntegerArray(0, fldsvals), j), curkey) <> 0 + j = j - 1 + If j < 0 Then + Exit Do + End If + Loop + j = j + 1 + Else + j = currow + End If + + Range = i + ROWe_FindOnSorted = j + match = True + Exit Function + Case 1 + minrow = currow + currow = (maxrow - minrow) / 2 + minrow + 'max row stays same + 'if the spread is 10 or less just loop through due to '\' errors + If maxrow - minrow <= 10 Then + currow = minrow + Do Until Me.MISCe_CompareString(ROWp_CreateKey(tbl, Me.PAp_2DGetIntegerArray(0, fldsvals), currow), curkey) = 0 + currow = currow + 1 + If currow > maxrow Then + match = False + ROWe_FindOnSorted = 0 + Exit Function + End If + Loop + End If + End Select + Loop + +errpath: + i = i + + +End Function + +Public Function ROWp_CreateKey(ByRef tbl() As String, ByRef flds() As Integer, ByRef row As Long) As String + + Dim i As Integer + Dim s As String + + For i = 0 To UBound(flds) + s = s & tbl(flds(i), row) + Next i + + ROWp_CreateKey = s + +End Function + +Public Function SHTp_GetAllCellsConcatenated(ByRef sh As Worksheet, ByRef maxw As Long, ByRef maxl As Long) As String + + Dim i As Long + Dim j As Long + Dim cs As String + + For i = 1 To maxl + For j = 1 To maxw + If j > 1 Then cs = cs & vbTab + cs = cs & sh.Cells(i, j) + Next j + cs = cs & " " & vbCrLf + Next i + + SHTp_GetAllCellsConcatenated = cs + +End Function + +Public Function MISCp_msgbox_cancel(ByRef Message As String, Optional ByRef TITLE As String = "") As Boolean + + Application.EnableCancelKey = xlDisabled + MsgB.tbMSG.text = Message + MsgB.Caption = TITLE + MsgB.tbMSG.ScrollBars = fmScrollBarsBoth + MsgB.Show + MISC_msgbox_cancel = MsgB.Cancel + Application.EnableCancelKey = xlInterrupt + +End Function + +Public Function TBLp_CrossJoin(ByRef tbl1() As String, ByRef tbl2() As String, ByRef headers As Boolean) As String() + + Dim t() As String + Dim i As Long + Dim j As Long + Dim k As Long + Dim m As Long + Dim h As Integer + + If headers Then + ReDim t(UBound(tbl1, 1) + UBound(tbl2, 1) + 1, UBound(tbl1, 2) * UBound(tbl2, 2)) + Else + ReDim t(UBound(tbl1, 1) + UBound(tbl2, 1) + 1, (UBound(tbl1, 2) + 1) * (UBound(tbl2, 2) + 1) - 1) + End If + + h = 0 + If headers Then + j = 0 + For i = 0 To UBound(tbl1, 1) + t(i, j) = tbl1(i, j) + Next i + For i = 0 To UBound(tbl2, 1) + t(i + UBound(tbl1, 1) + 1, j) = tbl2(i, j) + Next i + h = 1 + End If + + m = 0 + If headers Then m = 1 + For i = h To UBound(tbl1, 2) + For j = h To UBound(tbl2, 2) + For k = 0 To UBound(tbl1, 1) + t(k, m) = tbl1(k, i) + Next k + For k = 0 To UBound(tbl2, 1) + t(k + UBound(tbl1, 1) + 1, m) = tbl2(k, j) + Next k + m = m + 1 + Next j + Next i + + TBLp_CrossJoin = t + +End Function + + +Function ADOp_InsertRecordsS(ByRef Records() As String, ByRef con As Integer, ByVal TableName As String, Optional headers As Boolean) As Boolean + + Dim i As Integer + Dim j As Integer + + + If ADOo_rs(con) Is Nothing Then + Set ADOo_rs(con) = New ADODB.Recordset + End If + + If ADOo_rs(con).State = 1 Then + ADOo_rs(con).Close + End If + + Call ADOo_rs(con).Open(TableName, ADOo_con(con), adOpenDynamic, adLockPessimistic) + + ADOo_con(con).BeginTrans + + If headers = True Then + i = 1 + Else + i = 0 + End If + + While i <= UBound(Records, 2) + ADOo_rs(con).AddNew + j = 0 + While j <= UBound(Records, 1) + If Records(j, i) <> "" Then + ADOo_rs(con)(j) = Records(j, i) + End If + j = j + 1 + Wend + i = i + 1 + ADOo_rs(con).Update + Wend + + ADOo_con(con).CommitTrans + ADOo_rs(con).Close + +inserterror: + If Err.Number <> 0 Then + ADOo_con(con).RollbackTrans + ADOo_errstring = "Error encountered while adding records- #" & Err.Number & " " & Err.Description + ADOp_InsertRecordsS = False + Else + ADOp_InsertRecordsS = True + ADOo_errstring = "" + End If + +noconnectionstring: + +End Function + +Function MISCe_IsNull(ByRef stringexp As String, replacement As String) As String + + If stringexp = "" Then + IsNull = replacement + Else + IsNull = stringexp + End If + +End Function + + +Sub TBLp_Concatenate(ByRef ARY1() As String, ByRef ARY2() As String) + + Dim temp() As String + ReDim temp(UBound(ARY1, 1) + 1 + UBound(ARY2, 1), UBound(ARY1, 2) + UBound(ARY2, 2)) + Dim i As Integer + Dim j As Integer + Dim ub1 As Integer + Dim ub2 As Integer + + i = 0 + While i <= UBound(ARY1, 1) + j = 0 + While j <= UBound(ARY1, 2) + temp(i, j) = ARY1(i, j) + j = j + 1 + Wend + i = i + 1 + Wend + ub1 = i + ub2 = j - 1 + While i <= UBound(temp, 1) + j = 0 + While j <= ub2 + temp(i, j) = ARY2(i - ub1, j) + j = j + 1 + Wend + i = i + 1 + Wend + + ReDim Preserve temp(UBound(temp, 1), j - 1) + ARY1() = temp() +End Sub + +Sub SHTp_HyperlinkConvert(ByRef sheet As Worksheet, ByRef column As Integer, ByRef startrow As Integer, ByRef stopflag As String) + + Dim i As Integer + Dim sh As Worksheet + Set sh = sheet + i = startrow + Do Until sh.Cells(i, column) = stopflag + Call sh.Hyperlinks.Add(sh.Range(sh.Cells(i, column).address), sh.Cells(i, column)) + i = i + 1 + Loop + +End Sub + +Function FILEp_GetTXT(ByRef path As String, approxrecords) As String() + + Dim i As Long + Dim t() As String + ReDim t(0, approxrecords) + + Dim f As New Scripting.FileSystemObject + Dim ts As Scripting.TextStream + + Set ts = f.OpenTextFile(path, ForReading, False, TristateUseDefault) + + i = 0 + While Not ts.AtEndOfStream + t(0, i) = ts.ReadLine + i = i + 1 + Wend + ReDim Preserve t(0, i - 1) + ts.Close + + FILEp_GetTXT = t + +End Function + + +Function FILEp_CreateCSV(ByRef path As String, ByRef recs() As String) As Boolean + + Dim i As Long + Dim j As Long + Dim t() As String + Dim wl As String + Dim test_empty As String + Dim tsf As New ADODB.Stream + + On Error GoTo errh + +' Dim f As New Scripting.FileSystemObject +' Dim ts As Scripting.TextStream +' Set ts = f.CreateTextFile(path, True, True) +' ts.Close + + + tsf.Type = 2 + 'tsf.Charset = "utf-8" + tsf.Charset = "Windows-1252" + tsf.Open + + 'Set ts = f.OpenTextFile(path, ForReading, False, TristateUseDefault) + + i = 0 + While i <= UBound(recs, 2) + For j = 0 To UBound(recs, 1) + If j = 0 Then + test_empty = Replace(Replace(recs(j, i), ",", ""), """", "") + wl = Replace(Replace(recs(j, i), ",", ""), """", "") + Else + test_empty = test_empty & Replace(Replace(recs(j, i), ",", ""), """", "") + wl = wl & "," & Replace(Replace(recs(j, i), ",", ""), """", "") + End If + Next j + If Len(test_empty) > 0 Then + If i = 0 Then + Call tsf.WriteText(wl) + Else + wl = vbCrLf & wl + Call tsf.WriteText(wl) + End If + End If + i = i + 1 + Wend + Call tsf.SaveToFile(path, adSaveCreateOverWrite) + +errh: + If Err.Number = 0 Then + FILEp_CreateCSV = True + Else + MsgBox (Err.Description) + FILEp_CreateCSV = False + End If + +End Function + +Function FILEp_CreateTXT(ByRef path As String, ByRef recs() As String) As Boolean + + Dim i As Long + Dim j As Long + Dim t() As String + Dim wl As String + Dim test_empty As String + Dim tsf As New ADODB.Stream + + On Error GoTo errh + +' Dim f As New Scripting.FileSystemObject +' Dim ts As Scripting.TextStream +' Set ts = f.CreateTextFile(path, True, True) +' ts.Close + + + tsf.Type = 2 + tsf.Charset = "utf-8" + tsf.Open + + 'Set ts = f.OpenTextFile(path, ForReading, False, TristateUseDefault) + + i = 0 + While i <= UBound(recs, 2) + For j = 0 To UBound(recs, 1) + test_empty = recs(j, i) + wl = recs(j, i) + Next j + If Len(test_empty) > 0 Then + If i = 0 Then + Call tsf.WriteText(wl) + Else + wl = vbCrLf & wl + Call tsf.WriteText(wl) + End If + End If + i = i + 1 + Wend + Call tsf.SaveToFile(path, adSaveCreateOverWrite) + +errh: + If Err.Number = 0 Then + FILEp_CreateTXT = True + Else + MsgBox (Err.Description) + FILEp_CreateTXT = False + End If + +End Function + +Public Function ADOp_Exec(ByRef con As Integer, ByVal sql As String, Optional ApproxSixe As Long, Optional InclHeaders As Boolean, Optional ByVal value As ADOinterface, Optional ConnectTo As String, Optional IntgrtdSec As Boolean, Optional UserName As String, Optional Password As String, Optional textconfigs As String) As Boolean + + On Error GoTo errflag + + + If ADOo_con(con) Is Nothing Then Set ADOo_con(con) = New ADODB.Connection + + If ADOo_con(con).State = 0 Then + If Not Me.ADOp_OpenCon(con, value, ConnectTo, IntgrtdSec, UserName, Password, textconfigs) Then + GoTo conerr + End If + End If + + Call ADOo_con(con).Execute(sql) + ADOp_Exec = True + Exit Function + +conerr: + If Me.ADOo_errstring <> "" Then + ADOp_Exec = False + Exit Function + End If + +errflag: + + If Err.Number <> 0 Then + ADOp_Exec = False + Me.ADOo_errstring = "Error: " & Err.Number & vbCrLf & Err.Description + End If + +End Function + +Sub ADOp_CloseCon(con As Integer) + + ADOo_con(con).Close + +End Sub + +Public Function TBLp_Unpivot(ByRef arr() As String, ByRef pivot_field_header, ByRef content_header As String, ParamArray keepcols_stackcols()) As String() + + +On Error GoTo errh + + Dim keep() As Integer + Dim stack() As Integer + Dim i As Long + Dim j As Long + Dim k As Long + Dim r As Long + + keep = Me.PAp_2DGetIntegerArray(0, keepcols_stackcols) + stack = Me.PAp_2DGetIntegerArray(1, keepcols_stackcols) + + + Dim n() As String + ReDim n(UBound(keep) + 2, UBound(arr, 2) * (UBound(stack) + 1)) + + For i = 0 To UBound(keep) + n(i, 0) = arr(keep(i), 0) + Next i + + n(UBound(keep) + 1, 0) = pivot_field_header + n(UBound(keep) + 2, 0) = content_header + + r = 1 + For i = 0 To UBound(stack) 'loop through each stack field + For j = 1 To UBound(arr, 2) 'loop through each row in the array + For k = 0 To UBound(keep) 'loop through each field to keep + n(k, r) = arr(keep(k), j) + Next k + n(UBound(keep) + 1, r) = arr(stack(i), 0) 'arr col title + n(UBound(keep) + 2, r) = arr(stack(i), j) 'arr row content + r = r + 1 + Next j + Next i + +errh: + If Err.Number <> 0 Then + ADOo_errstring = ADOo_errstring & "Error in tblp_unpivot" & vbCrLf & Err.Description + ReDim n(0, 0) + n(0, 0) = ADOo_errstring + End If + + TBLp_Unpivot = n + +End Function + +Function TBLp_Stack_NewAr(ParamArray ar()) As String() + +On Error GoTo errh + + Dim ar1() As String + Dim ar2() As String + Dim i As Long + Dim j As Long + Dim k As Long + Dim r As Long + Dim out() As String + Dim ac As Long 'array count + Dim al As Long 'new arrray length + + 'get number of array is paramter array + ac = UBound(ar, 1) + 1 + + 'get length of each array and add total for final array redim + For i = 0 To ac - 1 + al = al + UBound(ar(i), 2) + Next i + + 'setup new combination array + ReDim Preserve out(UBound(ar(0), 1), al) + + 'set headers + For i = 0 To UBound(out, 1) + out(i, 0) = ar(0)(i, 0) + Next i + + 'get content + r = 1 + For k = 0 To ac - 1 'loop through each array + For j = 1 To UBound(ar(k), 2) 'loop through each row in each array + For i = 0 To UBound(out, 1) 'loop through each column of each row of each array + out(i, r) = ar(k)(i, j) + Next i + r = r + 1 + Next j + Next k + +errh: + If Err.Number <> 0 Then + ADOo_errstring = ADOo_errstring & "Error at TBLp_Stack_NewAr" & vbCrLf & Err.Description + ReDim out(0, 0) + out(0, 0) = ADOo_errstring + End If + + TBLp_Stack_NewAr = out + +End Function + +Sub TBLp_Stack_Overwrite(ar1() As String, ar2() As String) + +On Error GoTo errh + Dim i As Long + Dim j As Long + Dim r As Long + r = UBound(ar1, 2) + + ReDim Preserve ar1(UBound(ar1, 1), UBound(ar1, 2) + UBound(ar2, 2)) + + For j = 1 To UBound(ar2, 2) + For i = 0 To UBound(ar1, 1) + ar1(i, r) = ar2(i, j) + Next i + r = r + 1 + Next j + + +errh: + If Err.Number <> 0 Then + ADOo_errstring = ADOo_errstring & "Error at TBLp_Stack_Overwrite" & vbCrLf & Err.Description + ReDim ar1(0, 0) + ar1(0, 0) = ADOo_errstring + End If + + +End Sub + + +Public Function TXTp_Pad(ByRef topad As String, ByRef left_true_right_false As Boolean, ByRef padchar As String, ByRef padlength As Integer) As String + + If Len(topad) >= padlength Then + Pad = topad + Exit Function + End If + + + If left_true_right_false Then + Pad = String(padlength - Len(topad), padchar) & topad + Else + Pad = topad & String(padlength - Len(topad), padchar) + End If + + + +End Function + +Function TXTp_ParseCSVrow(ByRef csv() As String, row As Long, col As Integer) As String() + + Dim i As Long + Dim ci As Long + Dim cc() As Long + Dim qflag As Boolean + Dim rtn() As String + + ReDim cc(1000) + ci = 1 + cc(0) = 0 + For i = 1 To Len(csv(col, row)) + If Mid(csv(col, row), i, 1) = Chr(34) Then + If qflag = True Then + qflag = False + ElseIf qflag = False Then + qflag = True + End If + End If + If Mid(csv(col, row), i, 1) = "," Then + If Not qflag Then + cc(ci) = i + ci = ci + 1 + End If + End If + Next i + cc(ci) = i + + ReDim rtn(ci - 1) + + For i = 0 To UBound(rtn) + rtn(i) = Mid(csv(col, row), cc(i) + 1, cc(i + 1) - (cc(i) + 1)) + If Mid(rtn(i), 1, 1) = Chr(34) Then rtn(i) = Mid(rtn(i), 2, Len(rtn(i)) - 2) + Next i + + TXTp_ParseCSVrow = rtn + +End Function + + +Function json_from_list(keys As Range, values As Range) As String + + Dim json As String + Dim i As Integer + Dim first_comma As Boolean + Dim needs_braces As Integer + + needs_comma = False + needs_braces = 0 + + For i = 1 To keys.Cells.Count + If values.Cells(i).value <> "" Then + needs_braces = needs_braces + 1 + If needs_comma Then json = json & "," + needs_comma = True + If IsNumeric(values.Cells(i).value) Then + json = json & Chr(34) & keys.Cells(i).value & Chr(34) & ":" & values.Cells(i).value + Else + json = json & Chr(34) & keys.Cells(i).value & Chr(34) & ":" & Chr(34) & values.Cells(i).value & Chr(34) + End If + End If + Next i + + If needs_braces > 0 Then json = "{" & json & "}" + + json_from_list = json + +End Function + +Function json_concat(list As Range) As String + + Dim json As String + Dim i As Integer + + i = 0 + + For Each cell In list + If cell.value <> "" Then + i = i + 1 + If i = 1 Then + json = cell.value + Else + json = json & "," & cell.value + End If + End If + Next cell + + If i > 1 Then json = "[" & json & "]" + json_concat = json + +End Function + +Public Function ADOp_BuildInsertSQL(ByRef tbl() As String, Target As String, trim As Boolean, start As Long, ending As Long, ParamArray ftype()) As String + + + Dim i As Long + Dim j As Long + Dim sql As String + Dim rec As String + + sql = "INSERT INTO " & Target & " VALUES " & vbCrLf + For i = start To ending + rec = "" + If i <> start Then sql = sql & "," & vbCrLf + rec = rec & "(" + For j = 0 To UBound(tbl, 1) + If j <> 0 Then rec = rec & "," + Select Case ftype(0)(j) + Case "N" '-------N = numeric but should probably be N for numeric---- + If tbl(j, i) = "" Then + rec = rec & "NULL" + Else + rec = rec & Replace(tbl(j, i), "'", "''") + End If + Case "S" '-------S = string------------------------------------------ + If trim Then + rec = rec & "'" & LTrim(RTrim(Replace(tbl(j, i), "'", "''"))) & "'" + Else + rec = rec & "'" & Replace(tbl(j, i), "'", "''") & "'" + End If + Case "D" '-------D = date--------------------------------------------- + If LTrim(RTrim(tbl(j, i))) = "" Then + rec = rec & "CAST(NULL AS DATE)" + Else + rec = rec & "'" & tbl(j, i) & "'" + End If + Case Else '-------Assume text------------------------------------------ + If trim Then + rec = rec & "'" & LTrim(RTrim(Replace(tbl(j, i), "'", "''"))) & "'" + Else + rec = rec & "'" & Replace(tbl(j, i), "'", "''") & "'" + End If + End Select + Next j + rec = rec & ")" + sql = sql & rec + Next i + + ADOp_BuildInsertSQL = sql + +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 MISCe_MaxLng(ByRef base As Long, ByRef compare As Long) As Long + + If compare < base Then + MISCe_MaxLng = base + Exit Function + End If + + If compare = base Then + MISCe_MaxLng = compare + Exit Function + End If + + If compare > base Then + MISCe_MaxLng = compare + Exit Function + End If + +End Function + +Public Function markdown_from_table(ByRef tbl() As Variant, Optional number_format As String) As String + + + + Dim msl() As Integer + Dim md As String + Dim r As Integer + Dim c As Integer + + ReDim msl(UBound(tbl, 2)) + + '---determine max string length per column---- + For c = 1 To UBound(tbl, 2) + For r = 1 To UBound(tbl, 1) + If Len(tbl(r, c)) > msl(c) Then msl(c) = Len(tbl(r, c)) + Next r + Next c + + '---build markdown table----------- + For r = 1 To UBound(tbl, 1) + If r = 2 Then + 'If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then + md = md & "|" + For c = 1 To UBound(tbl, 2) + md = md & "---" & String(Me.MISCe_MaxInt(msl(c), 3) - 3, "-") & "|" + Next c + md = md & vbCrLf + End If + md = md & "|" + For c = 1 To UBound(tbl, 2) + md = md & tbl(r, c) & String(Me.MISCe_MaxInt(msl(c), 3) - Len(tbl(r, c)), " ") & "|" + Next c + md = md & vbCrLf + Next r + + markdown_from_table = md + +End Function + + +Public Function json_multirange(ByRef r As Range) As String + + Dim ar As Range + Dim r1() As Variant + Dim r2() As Variant + Dim rslt As String + Dim d() As String + Dim i As Integer + Dim dest As String + + i = 1 + For Each ar In r.Areas + + r1 = ar + If i > 1 Then + rslt = rslt & "," & Me.json_from_table(r1, CStr(r1(1, 1)), True) + Else + rslt = Me.json_from_table(r1, CStr(r1(1, 1)), True) + End If + i = i + 1 + Next ar + rslt = "{" & rslt & "}" + + json_multirange = rslt + +End Function + +Function markdown_whole_sheet(ByRef sh As Worksheet) As String + + Dim mr As Long + Dim mc As Long + Dim ir As Long + Dim ic As Long + Dim x As New TheBigOne + Dim tbl() As Variant + + tbl = sh.Range("A1:CZ1000").FormulaR1C1 + + For ic = 1 To UBound(tbl, 2) + For ir = 1 To UBound(tbl, 1) + If tbl(ir, ic) <> "" Then + mr = x.MISCe_MaxLng(ir, mr) + mc = x.MISCe_MaxLng(ic, mc) + End If + Next ir + Next ic + + tbl = sh.Range(sh.Cells(1, 1).address & ":" & sh.Cells(mr, mc).address).FormulaR1C1 + + markdown_whole_sheet = Me.markdown_from_table(tbl) + +End Function + +Function MISCe_col_to_letter(ByRef x As Long) As String + + If x > 26 Then + MISCe_colnum_to_letter = Chr(x \ 26 + 64) & Chr((x / 26 - x \ 26) * 26 + 64) + Else + MISCe_colnum_to_letter = Chr(x + 64) + End If + +End Function + + +Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, headers As Boolean, syntax As SQLsyntax, ByRef quote_headers As Boolean) As String + + + Dim i As Long + Dim j As Long + Dim sql As String + Dim rec As String + Dim type_flag() As String + Dim col_name As String + Dim start_row As Long + Dim rx As Object + Dim strip_text As String + Dim strip_num As String + Dim strip_date As String + + Set rx = CreateObject("vbscript.regexp") + rx.Global = True + + strip_text = "[^a-zA-Z0-9 \.\-\_\,\#\""]" + strip_num = "[^0-9\.]" + strip_date = "[^0-9\/\-\:\.]" + + ReDim type_flag(UBound(tbl, 1)) + For j = 0 To UBound(tbl, 1) + If IsNumeric(tbl(j, 1)) Then + If InStr(1, tbl(j, 1), ".") > 0 Then + type_flag(j) = "N" + Else + type_flag(j) = "S" + End If + Else + If Len(tbl(j, 1)) >= 6 Then + If IsDate(tbl(j, 1)) Then + type_flag(j) = "D" + Else + type_flag(j) = "S" + End If + Else + type_flag(j) = "S" + End If + End If + Next j + + rx.Pattern = strip_text + If headers Then + start_row = 1 + For i = 0 To UBound(tbl, 1) + If i > 0 Then col_name = col_name & "," + If quote_headers Then + col_name = col_name & """" & rx.Replace(tbl(i, 0), "") & """" + Else + col_name = col_name & rx.Replace(tbl(i, 0), "") + End If + Next i + Else + start_row = 0 + End If + + + For i = start_row To UBound(tbl, 2) + rec = "" + If i <> start_row Then sql = sql & "," & vbCrLf + rec = rec & "(" + For j = 0 To UBound(tbl, 1) + If j <> 0 Then rec = rec & "," + Select Case type_flag(j) + Case "N" '-------N = numeric but should probably be N for numeric---- + rx.Pattern = strip_num + If tbl(j, i) = "" Then + rec = rec & "CAST(NULL AS NUMERIC)" + Else + rec = rec & rx.Replace(tbl(j, i), "") + End If + Case "S" '-------S = string------------------------------------------ + rx.Pattern = strip_text + If LTrim(RTrim(tbl(j, i))) = "" Then + rec = rec & "CAST(NULL AS VARCHAR(255))" + Else + If trim Then + rec = rec & "'" & LTrim(RTrim(rx.Replace(tbl(j, i), ""))) & "'" + Else + rec = rec & "'" & rx.Replace(tbl(j, i), "") & "'" + + End If + End If + Case "D" '-------D = date--------------------------------------------- + rx.Pattern = strip_date + If LTrim(RTrim(tbl(j, i))) = "" Then + rec = rec & "CAST(NULL AS DATE)" + Else + rec = rec & "CAST('" & rx.Replace(tbl(j, i), "") & "' AS DATE)" + End If + Case Else '-------Assume text------------------------------------------ + rx.Pattern = strip_text + If LTrim(RTrim(tbl(j, i))) = "" Then + rec = rec & "CAST(NULL AS VARCHAR(255))" + Else + If trim Then + rec = rec & "'" & LTrim(RTrim(rx.Replace(tbl(j, i), ""))) & "'" + Else + rec = rec & "'" & rx.Replace(tbl(j, i), "") & "'" + End If + End If + End Select + Next j + rec = rec & ")" + sql = sql & rec + Next i + '---------build select-------------------------- + Select Case syntax + Case SQLsyntax.Db2 + sql = "SELECT * FROM TABLE( VALUES" & vbCrLf & sql & vbCrLf & ") x" + Case SQLsyntax.SqlServer + sql = "SELECT * FROM (VALUES" & vbCrLf & sql & vbCrLf & ") x" + Case SQLsyntax.PostgreSQL + sql = "SELECT * FROM (VALUES" & vbCrLf & sql & vbCrLf & ") x" + End Select + + If headers Then sql = sql & "(" & col_name & ")" + '---------final assignment---------------------- + SQLp_build_sql_values = sql + +End Function + +Public Function ARRAYp_get_range_string(ByRef r As Range) As String() + + Dim i As Long + Dim j As Long + Dim t1() As Variant + Dim t2() As String + + t1 = r + + '---convert to 0 lower bound array---- + + ReDim t2(UBound(t1, 1) - 1, UBound(t1, 2) - 1) + + + For i = 1 To UBound(t1, 1) + For j = 1 To UBound(t1, 2) + t2(i - 1, j - 1) = CStr(t1(i, j)) + Next j + Next i + + Call Me.ARRAYp_Transpose(t2) + + ARRAYp_get_range_string = t2 + + + + +End Function + +Public Function TBLp_range(ByRef dump() As Variant, ByVal upperleft As Range) As Range + + Dim width As Long + width = UBound(dump, 2) + Dim newcol As String + newcol = ConvertBase10(upperleft.column + UBound(dump, 2), "ABCDEFGHIJKLMNOPQRSTUVWXYZ") + + + +End Function + +Public Function Misc_ConvBase10(ByVal d As Double, ByVal sNewBaseDigits As String) As String +'credit: http://www.freevbcode.com/ShowCode.asp?ID=6604 + + Dim s As String, tmp As Double, i As Integer, lastI As Integer + Dim BaseSize As Integer + BaseSize = Len(sNewBaseDigits) + Do While val(d) <> 0 + tmp = d + i = 0 + Do While tmp >= BaseSize + i = i + 1 + tmp = tmp / BaseSize + Loop + If i <> lastI - 1 And lastI <> 0 Then s = s & String(lastI - i - 1, Left(sNewBaseDigits, 1)) 'get the zero digits inside the number + tmp = Int(tmp) 'truncate decimals + s = s + Mid(sNewBaseDigits, tmp + 1, 1) + d = d - tmp * (BaseSize ^ i) + lastI = i + Loop + s = s & String(i, Left(sNewBaseDigits, 1)) 'get the zero digits at the end of the number + Misc_ConvBase10 = s +End Function + +Public Function SHTp_get_block(point As Range) As Variant() + +' Dim left As Long +' Dim right As Long +' Dim top As Long +' Dim bot As Long +' Dim i As Long +' Dim lcol As String +' Dim rcol As String +' Dim r As Range +' +' +' i = 0 +' Do Until point.Worksheet.Cells(point.row, point.column + i) = "" +' i = i + 1 +' Loop +' If i <> 0 Then i = i - 1 +' right = point.column + i +' +' i = 0 +' Do Until point.Worksheet.Cells(point.row, point.column + i) = "" +' i = i - 1 +' Loop +' If i <> 0 Then i = i + 1 +' left = point.column + i +' +' i = 0 +' Do Until point.Worksheet.Cells(point.row + i, point.column) = "" +' i = i + 1 +' Loop +' If i <> 0 Then i = i - 1 +' bot = point.row + i +' +' i = 0 +' Do Until point.Worksheet.Cells(point.row + i, point.column) = "" +' i = i - 1 +' If point.row + i < 1 Then Exit Do +' Loop +' If i <> 0 Then i = i + 1 +' top = point.row + i +' +' lcol = Me.ColumnLetter(left) +' rcol = Me.ColumnLetter(right) + 'point.row (right) + + SHTp_get_block = point.CurrentRegion + +End Function + +Public Function SHTp_GetString(point As Range) As String() + + Dim x() As String + Dim pl() As Variant + pl = point.CurrentRegion + + SHTp_GetString = Me.TBLp_Transpose(Me.TBLp_VarToString(pl)) + + +End Function + + +Function ColumnLetter(ColumnNumber As Long) As String + Dim n As Long + Dim c As Byte + Dim s As String + + n = ColumnNumber + Do + c = ((n - 1) Mod 26) + s = Chr(c + 65) & s + n = (n - c) \ 26 + Loop While n > 0 + ColumnLetter = s +End Function + + + +Function TBLp_TestNumeric(ByRef table() As String, ByRef column As Long) As Boolean + + + Dim i As Long + Dim j As Long + Dim m As Long + + TBLp_TestNumeric = True + + j = 0 + i = 1 + For i = 1 To UBound(table, 2) + If Not IsNumeric(table(column, i)) And table(column, i) <> "" Then + TBLp_TestNumeric = False + Exit Function + End If + Next i + +End Function + +Function TBLp_Transpose(ByRef t() As String) As String() + + Dim i As Long + Dim j As Long + Dim x() As String + + If LBound(t, 1) = 1 Then + End If + + ReDim x(LBound(t, 2) To UBound(t, 2), LBound(t, 1) To UBound(t, 1)) + + For i = 1 To UBound(t, 2) + For j = 1 To UBound(t, 1) + x(i, j) = t(j, i) + Next j + Next i + + TBLp_Transpose = x +End Function + +Function TBLp_VarToString(ByRef t() As Variant) As String() + + Dim i As Long + Dim j As Long + Dim x() As String + + If LBound(t, 1) = 1 Then + End If + + ReDim x(LBound(t, 1) To UBound(t, 1), LBound(t, 2) To UBound(t, 2)) + + For i = LBound(t, 1) To UBound(t, 1) + For j = LBound(t, 2) To UBound(t, 2) + x(i, j) = t(i, j) + Next j + Next i + + TBLp_VarToString = x + +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 = 10 + + ' align header to body (should be done last!) + hdr.width = det.width + hdr.Left = det.Left + hdr.Top = det.Top - (hdr.Height - 1) + +End Sub + diff --git a/VBA/Windows_API.cls b/VBA/Windows_API.cls new file mode 100644 index 0000000..bec7900 --- /dev/null +++ b/VBA/Windows_API.cls @@ -0,0 +1,247 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Windows_API" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long +Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long +Private Declare PtrSafe Function GetClipboardOwner Lib "user32" () As LongPtr +Private Declare PtrSafe Function SetClipboardViewer Lib "user32" (ByVal hwnd As LongPtr) As LongPtr +Private Declare PtrSafe Function GetClipboardViewer Lib "user32" () As LongPtr +Private Declare PtrSafe Function ChangeClipboardChain Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndNext As LongPtr) As Long +Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr +Private Declare PtrSafe Function GetClipboardData Lib "user32" Alias "GetClipboardDataA" (ByVal wFormat As Long) As LongPtr +Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long +Private Declare PtrSafe Function CountClipboardFormats Lib "user32" () As Long +Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long +Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" _ + (ByVal wFormat As Long, _ + ByVal lpString As String, _ + ByVal nMaxCount As Long) As Long +Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long +Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long +Private Declare PtrSafe Function GetPriorityClipboardFormat Lib "user32" (lpPriorityList As Long, ByVal nCount As Long) As Long +Private Declare PtrSafe Function GetOpenClipboardWindow Lib "user32" () As LongPtr +Private Declare PtrSafe Function CharToOem Lib "user32" Alias "CharToOemA" _ + (ByVal lpszSrc As String, _ + ByVal lpszDst As String) As Long +Private Declare PtrSafe Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long +Private Declare PtrSafe Function CharToOemBuff Lib "user32" Alias "CharToOemBuffA" _ + (ByVal lpszSrc As String, _ + ByVal lpszDst As String, _ + ByVal cchDstLength As Long) As Long +Private Declare PtrSafe Function OemToCharBuff Lib "user32" Alias "OemToCharBuffA" _ + (ByVal lpszSrc As String, _ + ByVal lpszDst As String, _ + ByVal cchDstLength As Long) As Long +Private Declare PtrSafe Function CharUpper Lib "user32" Alias "CharUpperA" (ByVal lpsz As String) As String +Private Declare PtrSafe Function CharUpperBuff Lib "user32" Alias "CharUpperBuffA" (ByVal lpsz As String, ByVal cchLength As Long) As Long +Private Declare PtrSafe Function CharLower Lib "user32" Alias "CharLowerA" (ByVal lpsz As String) As String +Private Declare PtrSafe Function CharLowerBuff Lib "user32" Alias "CharLowerBuffA" (ByVal lpsz As String, ByVal cchLength As Long) As Long +Private Declare PtrSafe Function CharNext Lib "user32" Alias "CharNextA" (ByVal lpsz As String) As String +Private Declare PtrSafe Function CharPrev Lib "user32" Alias "CharPrevA" (ByVal lpszStart As String, ByVal lpszCurrent As String) As String +Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr +Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr +Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr +Private Declare PtrSafe Function GlobalHandle Lib "kernel32" (wMem As Any) As LongPtr +Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr +Private Declare PtrSafe Function GlobalReAlloc Lib "kernel32" (ByVal hMem As LongPtr, ByVal dwBytes As LongPtr, ByVal wFlags As Long) As LongPtr +Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long +Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long +Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" _ + (ByRef lpMsg As MSG, ByVal hwnd As Long, _ + ByVal wMsgFilterMin As Long, _ + ByVal wMsgFilterMax As Long, _ + ByVal wRemoveMsg As Long) As Long +Private Declare PtrSafe Function TranslateMessage Lib "user32" _ + (ByRef lpMsg As MSG) As Long +Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" _ + (ByVal hwnd As Long, _ + ByVal wMsg As Long, _ + ByVal wParam As Long, _ + lParam As Any) As Long +Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _ + (ByVal lpClassName As String, _ + ByVal lpWindowName As String) As Long + + + +Private Type POINTAPI + x As Long + Y As Long +End Type + +Private Type MSG + hwnd As Long + Message As Long + wParam As Long + lParam As Long + time As Long + pt As POINTAPI +End Type + +Private Const WM_KEYDOWN As Long = &H100 +Private Const PM_REMOVE As Long = &H1 +Private Const WM_CHAR As Long = &H102 +Private Const GHND As Long = &H42 +Private Const CF_TEXT = 1 +Private Const MAXSIZE = 40096 +Private bExitLoop As Boolean + + + +Public Sub SetClipboard(sUniText As String) + Dim iStrPtr As LongPtr + Dim iLen As LongPtr + Dim iLock As LongPtr + Const GMEM_MOVEABLE As Long = &H2 + Const GMEM_ZEROINIT As Long = &H40 + Const CF_UNICODETEXT As Long = &HD + OpenClipboard 0& + EmptyClipboard + iLen = LenB(sUniText) + 2& + iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen) + iLock = GlobalLock(iStrPtr) + lstrcpy iLock, StrPtr(sUniText) + GlobalUnlock iStrPtr + SetClipboardData CF_UNICODETEXT, iStrPtr + CloseClipboard +End Sub + +Public Sub ClipBoard_SetData(sUniText As String) + + + Dim hGlobalMemory As LongPtr + Dim lpGlobalMemory As LongPtr + Dim hClipMemory As LongPtr + Dim x As Long + + hGlobalMemory = GlobalAlloc(GHND, Len(sUniText) + 1) + + lpGlobalMemory = GlobalLock(hGlobalMemory) + + lpGlobalMemory = lstrcpy(lpGlobalMemory, sUniText) + + If GlobalUnlock(hGlobalMemory) <> 0 Then + GoTo OutOfHere2 + End If + + If OpenClipboard(0&) = 0 Then + Exit Sub + End If + + x = EmptyClipboard() + + hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) + +OutOfHere2: + + If CloseClipboard() = 0 Then + MsgBox ("ruh-roh") + End If + +End Sub + +Public Function GetClipboard() As String + Dim iStrPtr As Long + Dim iLen As Long + Dim iLock As Long + Dim sUniText As String + Const CF_UNICODETEXT As Long = 13& + OpenClipboard 0& + If IsClipboardFormatAvailable(CF_UNICODETEXT) Then + iStrPtr = GetClipboardData(CF_UNICODETEXT) + If iStrPtr Then + iLock = GlobalLock(iStrPtr) + iLen = GlobalSize(iStrPtr) + sUniText = String$(iLen \ 2& - 1&, vbNullChar) + lstrcpy StrPtr(sUniText), iLock + GlobalUnlock iStrPtr + End If + GetClipboard = sUniText + End If + CloseClipboard +End Function + + +Sub TrackKeyPressInit() + + Dim msgMessage As MSG + Dim bCancel As Boolean + Dim iKeyCode As Integer + Dim lXLhwnd As Long + + On Error GoTo errHandler: + Application.EnableCancelKey = xlErrorHandler + 'initialize this boolean flag. + bExitLoop = False + 'get the app hwnd. + lXLhwnd = FindWindow("XLMAIN", Application.Caption) + Do + WaitMessage + 'check for a key press and remove it from the msg queue. + If PeekMessage _ + (msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then + 'strore the virtual key code for later use. + iKeyCode = msgMessage.wParam + 'translate the virtual key code into a char msg. + TranslateMessage msgMessage + PeekMessage msgMessage, lXLhwnd, WM_CHAR, _ + WM_CHAR, PM_REMOVE + 'for some obscure reason, the following + 'keys are not trapped inside the event handler + 'so we handle them here. + If iKeyCode = vbKeyBack Then SendKeys "{BS}" + If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}" + 'assume the cancel argument is False. + bCancel = False + 'the VBA RaiseEvent statement does not seem to return ByRef arguments + 'so we call a KeyPress routine rather than a propper event handler. + Sheet_KeyPress ByVal msgMessage.wParam, ByVal iKeyCode, ByVal Selection, bCancel + 'if the key pressed is allowed post it to the application. + If bCancel = False Then + PostMessage _ + lXLhwnd, msgMessage.Message, msgMessage.wParam, 0 + End If + End If +errHandler: + 'allow the processing of other msgs. + DoEvents + Loop Until bExitLoop + +End Sub + +Sub StopKeyWatch() + + 'set this boolean flag to exit the above loop. + bExitLoop = True + +End Sub + + +'\\This example illustrates how to catch worksheet +'\\Key strokes in order to prevent entering numeric +'\\characters in the Range "A1:D10" . +Private Sub Sheet_KeyPress(ByVal KeyAscii As Integer, ByVal KeyCode As Integer, ByVal Target As Range, Cancel As Boolean) + + Const MSG As String = "Numeric Characters are not allowed in" & vbNewLine & "the Range: """ + Const TITLE As String = "Invalid Entry !" + + If Not Intersect(Target, Range("A1:D10")) Is Nothing Then + If Chr(KeyAscii) Like "[0-9]" Then + MsgBox MSG & Range("A1:D10").address(False, False) _ + & """ .", vbCritical, TITLE + Cancel = True + End If + End If + +End Sub + + + diff --git a/VBA/build.frm b/VBA/build.frm new file mode 100644 index 0000000..30ee2db --- /dev/null +++ b/VBA/build.frm @@ -0,0 +1,81 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} build + Caption = "UserForm1" + ClientHeight = 3015 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 8100 + 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 +Public part As String +Public bill As String +Public ship As String +Public useval As Boolean +Option Explicit + + + + +Private Sub cbBill_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) + Select Case KeyCode + Case 13 + useval = True + Me.Hide + Case 27 + useval = False + Me.Hide + End Select +End Sub + + +Private Sub cbPart_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) + + Select Case KeyCode + Case 13 + useval = True + Me.Hide + Case 27 + useval = False + Me.Hide + End Select + +End Sub + + +Private Sub cbShip_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) + Select Case KeyCode + Case 13 + useval = True + Me.Hide + Case 27 + useval = False + Me.Hide + End Select +End Sub + +Private Sub UserForm_Activate() + + useval = False + + cbPart.value = part + cbBill.value = bill + cbShip.value = ship + + cbPart.list = Application.transpose(Worksheets("mdata").Range("A2:A2").CurrentRegion) + 'cbPart.list(1).Remove + cbBill.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion) + 'cbPart.list(1).Remove + cbShip.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion) + 'cbPart.list(1).Remove + + +End Sub + + + diff --git a/VBA/build.frx b/VBA/build.frx new file mode 100644 index 0000000..d9f12a0 Binary files /dev/null and b/VBA/build.frx differ diff --git a/VBA/changes.frm b/VBA/changes.frm new file mode 100644 index 0000000..f296776 --- /dev/null +++ b/VBA/changes.frm @@ -0,0 +1,134 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} changes + Caption = "History" + ClientHeight = 7785 + 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 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 + + + +Private Sub lbHist_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) + + Select Case KeyCode + Case 46 + Call Me.delete_selected + Case 27 + Call Me.Hide + End Select + +End Sub + + + +Private Sub tbPrint_Change() + +End Sub + + +Private Sub UserForm_Activate() + + Dim fail As Boolean + + 'x = handler.list_changes("{""user"":""" & Application.UserName & """}", fail) + x = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & Sheets("data").Cells(2, 5) & """}}", fail) + If fail Then + Me.Hide + Exit Sub + End If + Me.lbHist.list = x + + lbHEAD.ColumnCount = lbHist.ColumnCount + lbHEAD.ColumnWidths = lbHist.ColumnWidths + + ' add header elements + lbHEAD.clear + lbHEAD.AddItem + lbHEAD.list(0, 0) = "Modifier" + lbHEAD.list(0, 1) = "Owner" + lbHEAD.list(0, 2) = "When" + lbHEAD.list(0, 3) = "Tag" + lbHEAD.list(0, 4) = "Comment" + lbHEAD.list(0, 5) = "Sales" + lbHEAD.list(0, 6) = "id" + Dim tbo As New TheBigOne + Call tbo.frmListBoxHeader(Me.lbHEAD, Me.lbHist, "Modifier", "Owner", "When", "Tag", "Comment", "Sales", "id") + + + ' make it pretty + 'body.ZOrder (1) + 'lbHEAD.ZOrder (0) + 'lbHEAD.SpecialEffect = fmSpecialEffectFlat + 'lbHEAD.BackColor = RGB(200, 200, 200) + 'lbHEAD.Height = 10 + + ' align header to body (should be done last!) + 'lbHEAD.width = lbHist.width + 'lbHEAD.Left = lbHist.Left + 'lbHEAD.Top = lbHist.Top - (lbHEAD.Height - 1) + +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?", vbOKCancel) = vbCancel 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 + + Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh + + Me.lbHist.clear + Me.Hide + +End Sub diff --git a/VBA/changes.frx b/VBA/changes.frx new file mode 100644 index 0000000..c2b84e9 Binary files /dev/null and b/VBA/changes.frx differ diff --git a/VBA/fpvt.frm b/VBA/fpvt.frm new file mode 100644 index 0000000..b3f0024 --- /dev/null +++ b/VBA/fpvt.frm @@ -0,0 +1,1368 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt + Caption = "Forecast Adjustment" + ClientHeight = 8445.001 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 8805.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 +Public mod_adjust As Boolean +Private month() As Variant +Private mload() As Variant +Private adjust As Object +Private nomonth As Boolean +Private mline As Integer +Private clear_lb As Boolean +Private load_tb As Boolean +Private set_Price As Boolean +Private sp As Object +Private basket() As Variant +Private cust() As Variant +Private vSwap() As Variant +Private swapline As Integer +Private set_swapalt As Boolean +Private return_swap As Boolean +Private jswap As Object +Private cswap As Object +Private cust_s() As Boolean + +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 + +Private bVolm As Double +Private bValm As Double +Private bPrcm As Double +Private pVolm As Double +Private pValm As Double +Private pPrcm As Double +Private aVolm As Double +Private aValm As Double +Private aPrcm As Double +Private fVolm As Double +Private fValm As Double +Private fPrcm As Double + +Option Explicit + +Private Sub cbCancel_Click() + + tbAdjVol.value = 0 + tbAdjVal.value = 0 + tbAdjPrice.value = 0 + fpvt.Hide + +End Sub + + +Private Sub butAdjust_Click() + + Dim fail As Boolean + Dim doc As String + + If tbAPI.text = "" Then + MsgBox ("No adjustments provided") + Exit Sub + End If + + If cbTAG.text = "" Then + MsgBox ("no tag was selected") + Exit Sub + End If + + Select Case fpvt.mp.SelectedItem.Name + Case "pageSWAP" + doc = tbAPI.text + If doc = "" Then + MsgBox ("no part swap setup") + Exit Sub + End If + Case "pAnn" + doc = tbAPI.text + If doc = "" Then + MsgBox ("no adjustements are ready") + Exit Sub + End If + Case Else + doc = tbAPI.text + 'MsgBox ("not on an adjustable tab") + 'Exit Sub + End Select + + Call handler.request_adjust(doc, fail) + If fail Then + MsgBox ("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 butMAdjust_Click() + + Dim i As Integer + + For i = 1 To 12 + If month(i, 10) <> "" Then + Call handler.request_adjust(CStr(month(i, 10))) + End If + Next i + + Me.Hide + + +End Sub + +Private Sub butMCancel_Click() + + Me.Hide + +End Sub + +Private Sub cbGoSheet_Click() + + Worksheets("month").tbMCOM.text = "" + Worksheets("month").sbMPV.value = 0 + Worksheets("month").sbMPP.value = 0 + + Me.Hide + months.cbMTAG.value = "" + Worksheets("month").Visible = xlSheetVisible + Sheets("month").Select + +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 lbMonth_Change() + + If clear_lb Or load_tb Then Exit Sub + + Dim i As Long + For i = 0 To 13 + If lbMonth.Selected(i) Then + mline = i + If i <> 0 And i <> 13 Then + Me.load_var + Me.load_mbox + Else + load_tb = True + tbMBaseVal.value = "" + tbMBaseVol.value = "" + tbMBasePrice.value = "" + tbmPAVal.value = "" + tbMPAVol.value = "" + tbMPAPrice.value = "" + tbMFVal.value = "" + tbMFVol.value = "" + tbMFPrice.value = "" + tbMAVal.value = "" + tbMAVol.value = "" + tbMAPrice.value = "" + load_tb = False + End If + Exit For + End If + Next i + + + +End Sub + +Private Sub cbPLIST_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) + + If KeyCode <> 13 Then Exit Sub + Dim i As Long + If set_swapalt Then Exit Sub + Dim vtable() As Variant + Dim ptable As String + + Dim rx As Object + Set rx = CreateObject("vbscript.regexp") + rx.Global = True + rx.Pattern = " - .*" + + For i = 0 To Me.lbSWAP.ListCount - 1 + If Me.lbSWAP.Selected(i) Then + vSwap(swapline, 2) = rx.Replace(cbPLIST.value, "") + return_swap = True + lbSWAP.list = vSwap + return_swap = False + End If + Next i + + vtable = x.ARRAYp_TransposeVar(vSwap) + vtable = x.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit") + vtable = x.ARRAYp_TransposeVar(vtable) + ptable = x.json_from_table_zb(vtable, "rows", True, False) + Set jswap("swap") = JsonConverter.ParseJson(ptable) + + jswap("scenario")("version") = handler.plan + jswap("scenario")("iter") = handler.basis + jswap("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss") + jswap("user") = Application.UserName + jswap("source") = "adj" + jswap("message") = tbCOM.text + jswap("tag") = cbTAG.text + jswap("type") = "swap" + + tbAPI.text = JsonConverter.ConvertToJson(jswap) + +End Sub + +Private Sub dbGETSWAP_Click() + + Dim doc As String + Dim j As Object + Dim fail As Boolean + Dim l() As Variant + Dim ptable As String + Dim vtable() As Variant + + Set j = JsonConverter.ParseJson("{""scenario"":" & handler.scenario & "}") + 'Set j = JsonConverter.ParseJson(doc) + j("new_mold") = pickSWAP.text + doc = JsonConverter.ConvertToJson(j) + vSwap = handler.get_swap_fit(doc, fail) + lbSWAP.list = vSwap + 'Call x.frmListBoxHeader(lbSWAPH, lbSWAP, "Original", "Sales", "Replacement", "Fit") + + cbPLIST.list = Application.transpose(Worksheets("mdata").Range("A2:A26267")) + + '---------build change------------- + Set jswap = j + vtable = x.ARRAYp_TransposeVar(vSwap) + vtable = x.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit") + vtable = x.ARRAYp_TransposeVar(vtable) + ptable = x.json_from_table_zb(vtable, "rows", True, False) + Set jswap("swap") = JsonConverter.ParseJson(ptable) + + jswap("scenario")("version") = handler.plan + jswap("scenario")("iter") = handler.basis + jswap("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss") + jswap("user") = Application.UserName + jswap("source") = "adj" + jswap("message") = tbCOM.text + jswap("tag") = cbTAG.text + jswap("type") = "swap" + + tbAPI.text = JsonConverter.ConvertToJson(jswap) + + +End Sub + + +Private Sub lbSWAP_Change() + + Dim i As Long + If return_swap Then Exit Sub + + For i = 0 To Me.lbSWAP.ListCount - 1 + If Me.lbSWAP.Selected(i) Then + set_swapalt = True + cbPLIST.value = vSwap(i, 2) + set_swapalt = False + swapline = i + End If + Next i + +End Sub + +Private Sub lbSWAP_DblClick(ByVal Cancel As MSForms.ReturnBoolean) + +' Dim rx As Object +' Set rx = CreateObject("vbscript.regexp") +' rx.Global = True +' rx.Pattern = " - .*" +' Dim match As Object +' Dim i As Long +' Dim v As Variant +' +' 'v = Me.lbSWAP.list +' +' For i = 0 To Me.lbSWAP.ListCount - 1 +' If Me.lbSWAP.Selected(i) Then +' part.Show +' If Not part.useval Then +' Exit Sub +' End If +' 'vSwap(i, 3) = rx.Execute(part.cbPart.value) +' 'v(i, 2) = rx.Replace(part.cbPart.value, "") +' 'Me.lbSWAP.list = v +' End If +' Next i +' +End Sub + + +Private Sub opEditPrice_Click() + + opPlugVol.Enabled = False + opPlugPrice.Enabled = False + 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.Enabled = True + opPlugPrice.Enabled = True + 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 opEditPriceM_Click() + + opmvol.Enabled = False + opmprice.Enabled = False + opmvol.Visible = False + opmprice.Visible = False + opmprice.value = True + opmvol.value = True + + tbMFPrice.Enabled = True + tbMFPrice.BackColor = &H80000018 + tbMFVal.Enabled = False + tbMFVal.BackColor = &H80000005 + tbMFVol.Enabled = True + tbMFVol.BackColor = &H80000018 + +End Sub + +Private Sub opEditSalesM_Click() + + opmvol.Enabled = True + opmprice.Enabled = True + opmvol.Visible = True + opmprice.Visible = True + + tbMFPrice.Enabled = False + tbMFPrice.BackColor = &H80000005 + tbMFVal.Enabled = True + tbMFVal.BackColor = &H80000018 + tbMFVol.Enabled = False + tbMFVol.BackColor = &H80000005 + +End Sub + +Private Sub opEditVolM_Click() + + opmvol.Enabled = False + opmprice.Enabled = False + opmprice.value = False + opmvol.value = True + opmvol.Enabled = False + opmprice.Enabled = False + opmvol.Visible = False + opmprice.Visible = False + + tbMFPrice.Enabled = False + tbMFPrice.BackColor = &H80000005 + tbMFVal.Enabled = False + tbMFVal.BackColor = &H80000005 + tbMFVol.Enabled = True + tbMFVol.BackColor = &H80000018 +End Sub + +Private Sub opPlugPrice_Click() + calc_val + If opPlugPrice.value = True Then + opPlugPrice.BackColor = -2147483624 + Else + opPlugPrice.BackColor = -2147483644 + End If + If opPlugVol.value = True Then + opPlugVol.BackColor = -2147483624 + Else + opPlugVol.BackColor = -2147483644 + End If + +End Sub + +Private Sub opPlugVol_Click() + calc_val + If opPlugVol.value = True Then + opPlugVol.BackColor = -2147483624 + Else + opPlugVol.BackColor = -2147483644 + End If + If opPlugPrice.value = True Then + opPlugPrice.BackColor = -2147483624 + Else + opPlugPrice.BackColor = -2147483644 + End If +End Sub + +Private Sub pickSWAP_Change() + +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 + +'--------------------------------monthly buttons-------------------------------------- + +Private Sub opmPrice_Click() + calc_mval +End Sub + +Private Sub opmVol_Click() + calc_mval +End Sub + +Private Sub tbmfPrice_Change() + + If mline = 0 Then Exit Sub + If clear_lb Or load_tb Then Exit Sub + set_Price = True + If opEditPriceM Then calc_mprice + set_Price = False + +End Sub + + + +Private Sub tbMFVal_Change() + + If mline = 0 Then Exit Sub + If clear_lb Or load_tb Then Exit Sub + If opEditSalesM Then calc_mval + +End Sub + +Private Sub tbmfVol_Change() + + If mline = 0 Then Exit Sub + If clear_lb Or load_tb Then Exit Sub + If opEditPriceM Then calc_mprice + +End Sub + +Private Sub tbpd_Change() + + If load_tb Then Exit Sub + If Not VBA.IsNumeric(tbpd.value) Then + tbpd = "0" + End If + 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 + tbpd = "0" + End If + 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 + tbpd = "0" + End If + tbFcVol = (bVol + pVol) * (1 + tbpv.value / 100) + + +End Sub + +Private Sub UserForm_Activate() + + Dim i As Long + Dim j As Long + Dim k As Long + Dim ok As Boolean + Dim tags() As Variant + + Me.Caption = "Forecast Adjust " & Worksheets("config").Cells(8, 2) + Me.mp.Visible = False + + Me.lheader = "Loading..." + + Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok) + Call x.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection") + + Me.lheader = "Ready" + + If Not ok Then + fpvt.Hide + Application.StatusBar = False + Exit Sub + End If + + + '---show existing adjustment if there is one---- + fpvt.mod_adjust = False + 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 + fpvt.Hide + Application.StatusBar = False + Exit Sub + End If + + For i = 1 To sp("package")("totals").Count + Select Case sp("package")("totals")(i)("order_season") + Case 2023 + 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------------------------------------------------------- + + k = 0 + '--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)("2023 qty") + month(i, 2) = sp("package")("mpvt")(i)("2024 base qty") + month(i, 3) = sp("package")("mpvt")(i)("2024 adj qty") + month(i, 4) = sp("package")("mpvt")(i)("2024 tot qty") + month(i, 5) = sp("package")("mpvt")(i)("2023 value_usd") + month(i, 6) = sp("package")("mpvt")(i)("2024 base value_usd") + month(i, 7) = sp("package")("mpvt")(i)("2024 adj value_usd") + month(i, 8) = sp("package")("mpvt")(i)("2024 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 + + month(0, 0) = "month" + month(13, 0) = "total" + month(0, 1) = "2023 qty" + month(0, 2) = "2024 base qty" + month(0, 3) = "2024 adj qty" + month(0, 4) = "2024 qty" + month(0, 5) = "2023 val" + month(0, 6) = "2024 base val" + month(0, 7) = "2024 adj val" + month(0, 8) = "2024 val" + + Me.crunch_array + + ReDim basket(sp("package")("basket").Count, 3) + +' basket(0, 0) = "order_season" +' basket(0, 1) = "order_month" +' basket(0, 2) = "version" +' basket(0, 3) = "iter" +' basket(0, 4) = "part_descr" +' basket(0, 5) = "bill_cust_descr" +' basket(0, 6) = "ship_cust_descr" +' basket(0, 7) = "units" +' basket(0, 8) = "value_usd" + 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")("base")(i)("order_season") + 'basket(i, 1) = sp("package")("base")(i)("order_month") + 'basket(i, 2) = sp("package")("base")(i)("version") + 'basket(i, 3) = sp("package")("base")(i)("iter") + 'basket(i, 4) = sp("package")("base")(i)("part_descr") + 'basket(i, 5) = sp("package")("base")(i)("bill_cust_descr") + 'basket(i, 6) = sp("package")("base")(i)("ship_cust_descr") + 'basket(i, 7) = sp("package")("base")(i)("units") + 'basket(i, 8) = sp("package")("base")(i)("value_usd") + 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 + + '---------------get list of customers---------------------------- + + ReDim cust(sp("package")("customers").Count - 1, 3) + + + For i = 0 To UBound(cust, 1) + cust(i, 0) = sp("package")("customers")(i + 1)("bill_cust_descr") + cust(i, 1) = "" + cust(i, 2) = sp("package")("customers")(i + 1)("ship_cust_descr") + cust(i, 3) = "" + Next i + + Call x.frmListBoxHeader(lbCUSTH, lbCUST, "Bill-To", "Replace", "Ship-To", "Replace") + + + '-------------load tags------------------------------- + If Not IsNull(sp("package")("tags")) Then + ReDim tags(sp("package")("tags").Count - 1, 0) + For i = 1 To sp("package")("tags").Count + tags(i - 1, 0) = sp("package")("tags")(i) + Next i + cbTAG.list = tags + Sheets("month").cbMTAG.list = tags + cbTAG.ListRows = UBound(tags, 1) + 1 + months.cbMTAG.ListRows = UBound(tags, 1) + 1 + End If + + '----------reset spinner buttons---------------------- + sbpv.value = 0 + sbpp.value = 0 + sbpd.value = 0 + + '--------reset swap tab------------------------------- + lbSWAP.clear + pickSWAP.value = "" + pickSWAP.text = Mid(sp("package")("basket")(1)("part_descr"), 1, 8) + pickSWAP.list = Application.transpose(Worksheets("mdata").Range("F2:F2").CurrentRegion) + cbBT.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion) + cbST.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion) + lbCUST.list = cust + Call x.frmListBoxHeader(Me.lbSWAPH, Me.lbSWAP, "Original", "Sales", "Replacement", "Fit") + + '---------price volume radio button colors---------- + If opPlugPrice.value = True Then + opPlugPrice.BackColor = -2147483624 + Else + opPlugPrice.BackColor = -2147483644 + End If + If opPlugVol.value = True Then + opPlugVol.BackColor = -2147483624 + Else + opPlugVol.BackColor = -2147483644 + End If + + 'Application.Calculation = xlCalculationManual + Call handler.month_tosheet(month, basket) + Application.StatusBar = False + + Me.mp.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 + + 'mline = 0 + clear_lb = True + lbMonth.clear + lbMonth.list = mload + clear_lb = False + +End Sub + +Private Sub lbCUST_Change() + + Dim i As Long + Dim x() As Variant + + x = lbCUST.list + For i = 0 To UBound(x, 1) + If lbCUST.Selected(i) Then Exit For + Next i + cbBT.text = x(i, 0) + cbST.text = x(i, 2) + + +End Sub + + +Private Sub cbBT_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) + + If KeyCode <> 13 Then Exit Sub + + Dim i As Long + Dim x() As Variant + + x = lbCUST.list + For i = 0 To UBound(x, 1) + If lbCUST.Selected(i) Then x(i, 1) = Me.rev_cust(cbBT.text) + Next i + lbCUST.list = x + Call Me.build_cust_swap + +End Sub + +Private Sub cbST_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) + + If KeyCode <> 13 Then Exit Sub + + Dim i As Long + Dim x() As Variant + + x = lbCUST.list + For i = 0 To UBound(x, 1) + If lbCUST.Selected(i) Then x(i, 3) = Me.rev_cust(cbST.text) + Next i + lbCUST.list = x + Call Me.build_cust_swap + + +End Sub + +Sub build_cust_swap() + + Dim vtable() As Variant + Dim ptable As String + vtable = lbCUST.list + vtable = x.ARRAYp_TransposeVar(vtable) + vtable = x.ARRAYp_zerobased_addheader(vtable, "bill", "bill_r", "ship", "ship_r") + vtable = x.ARRAYp_TransposeVar(vtable) + ptable = x.json_from_table_zb(vtable, "rows", True, False) + Set cswap = JsonConverter.ParseJson("{""scenario"":" & handler.scenario & "}") + cswap("scenario")("version") = handler.plan + cswap("scenario")("iter") = handler.basis + cswap("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss") + cswap("user") = Application.UserName + cswap("source") = "adj" + cswap("message") = tbCOM.text + cswap("tag") = cbTAG.text + cswap("type") = "cust_swap" + Set cswap("swap") = JsonConverter.ParseJson(ptable) + + tbAPI.text = JsonConverter.ConvertToJson(cswap) + + +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_var() + + 'base + bVolm = co_num(month(mline, 2), 0) + bValm = co_num(month(mline, 6), 0) + + 'prior adjust + pVolm = co_num(month(mline, 3), 0) + pValm = co_num(month(mline, 7), 0) + + 'current forecast + fVolm = co_num(month(mline, 4), 0) + fValm = co_num(month(mline, 8), 0) + + 'adjustment + aVolm = fVolm - (bVolm + pVolm) + aValm = fValm - (bValm + pValm) + + + If month(mline, 9) = "addmonth" Then + nomonth = True + bPrcm = month(13, 6) / month(13, 2) + fPrcm = month(13, 8) / month(13, 4) + + Else + 'prices + If bVolm <> 0 Then bPrcm = bValm / bVolm + If (bVolm + pVolm) <> 0 Then pPrcm = (pValm + bValm) / (bVolm + pVolm) - bPrcm + If fVolm <> 0 Then fPrcm = fValm / fVolm + aPrcm = fPrcm - (bPrcm + pPrcm) + End If + +End Sub + +Sub load_mbox() + + load_tb = True + + tbMBaseVol = Format(bVolm, "#,###") + tbMBaseVal = Format(bValm, "#,###") + tbMBasePrice = Format(bPrcm, "0.00000") + + tbMPAVol = Format(pVolm, "#,###") + tbmPAVal = Format(pValm, "#,###") + tbMPAPrice = Format(pPrcm, "0.00000") + + tbMFVol = Format(fVolm, "#,###") + tbMFVal = Format(fValm, "#,###") + If Not set_Price Then tbMFPrice = Format(fPrcm, "0.#####") + + tbMAVol = Format(aVolm, "#,###") + tbMAVal = Format(aValm, "#,###") + tbMAPrice = Format(aPrcm, "0.00000") + + load_tb = False + +End Sub + +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 + +Sub load_array() + + 'base + month(mline, 2) = bVolm + month(mline, 6) = bValm + + 'prior adjust + month(mline, 3) = pVolm + month(mline, 7) = pValm + + 'current forecast + month(mline, 4) = fVolm + month(mline, 8) = fValm + + Me.crunch_array + +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() + + 'If IsNumeric(tbFcPrice.value) And tbFcPrice.value <> 0 And IsNumeric(tbFcVol.value) And tbFcVol.value <> 0 Then + 'If IsNumeric(tbFcPrice.value) And IsNumeric(tbFcVol.value) And tbFcVol.value <> 0 Then + + 'If IsNumeric(tbFcPrice.value) And IsNumeric(tbFcVol.value) Then + 'capture currently changed item + + 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 + + +Sub calc_mval() + + Dim pchange As Double + Dim j As Object + + If IsNumeric(tbMFVal.value) Then + 'get textbox value + fValm = tbMFVal.value + 'do calculations + aValm = fValm - bValm - pValm + + '---------if volume adjustment method is selected, scale the volume up---------------------------------- + If nomonth Then + fVolm = fValm / bPrcm + fPrcm = bPrcm + Else + If opmvol Then + pchange = fValm / (pValm + bValm) + fVolm = (pVolm + bVolm) * pchange + Else + fVolm = pVolm + bVolm + End If + End If + If fVolm = 0 Then + fPrcm = 0 + Else + fPrcm = fValm / fVolm + End If + aVolm = fVolm - (bVolm + pVolm) + aPrcm = fPrcm - (bPrcm + pPrcm) + Else + aVolm = fVolm - bVolm - pVolm + aPrcm = 0 + End If + tbMFVal = Format(tbMFVal, "#,###") + + 'build json + + Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}") + j("scenario")("version") = handler.plan + j("scenario")("iter") = handler.basis + j("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss") + j("user") = Application.UserName + j("source") = "adj" + If opEditSalesM Then + If opmvol Then + If nomonth Then + j("type") = "addmonth_v" + j("month") = month(mline, 0) + Else + j("type") = "scale_v" + j("scenario")("order_month") = month(mline, 0) + End If + j("amount") = aValm + Else + If nomonth Then + j("type") = "addmonth_p" + j("month") = month(mline, 0) + Else + j("type") = "scale_p" + j("scenario")("order_month") = month(mline, 0) + End If + j("amount") = aValm + End If + Else + If nomonth Then + j("type") = "addmonth_vp" + j("month") = month(mline, 0) + Else + j("type") = "scale_vp" + j("scenario")("order_month") = month(mline, 0) + End If + j("qty") = aVolm + j("amount") = aValm + End If + + month(mline, 10) = JsonConverter.ConvertToJson(j) + tbAPI = JsonConverter.ConvertToJson(j) + + Me.load_mbox + Me.load_array + +End Sub + +Sub calc_mprice() + + Dim j As Object + + If IsNumeric(tbMFPrice.value) And tbMFPrice.value <> 0 And IsNumeric(tbMFVol.value) And tbMFVol.value <> 0 Then + 'capture currently changed item + fVolm = tbMFVol.value + fPrcm = tbMFPrice.value + 'calc + fValm = fPrcm * fVolm + aValm = fValm - bValm - pValm + aVolm = fVolm - (bVolm + pVolm) + If nomonth Then + aPrcm = fValm / fVolm - bPrcm + Else + aPrcm = fValm / fVolm - ((bValm + pValm) / (bVolm + pVolm)) + End If + Else + fValm = 0 + aValm = fValm - bValm - pValm + End If + + 'build json + Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}") + j("scenario")("version") = handler.plan + j("scenario")("iter") = handler.basis + j("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss") + j("user") = Application.UserName + j("source") = "adj" + If opEditSalesM Then + If opmvol Then + If nomonth Then + j("type") = "addmonth_v" + j("month") = month(mline, 0) + Else + j("type") = "scale_v" + j("scenario")("order_month") = month(mline, 0) + End If + j("amount") = aValm + Else + If nomonth Then + 'this scenario should be prevented + j("type") = "addmonth_v" + j("month") = month(mline, 0) + Else + j("type") = "scale_p" + j("scenario")("order_month") = month(mline, 0) + End If + j("amount") = aValm + End If + Else + If nomonth Then + j("type") = "addmonth_vp" + j("month") = month(mline, 0) + Else + If aVolm = 0 Then + j("type") = "scale_p" + Else + j("type") = "scale_vp" + End If + j("scenario")("order_month") = month(mline, 0) + End If + j("qty") = aVolm + j("amount") = aValm + End If + + month(mline, 10) = JsonConverter.ConvertToJson(j) + tbAPI = JsonConverter.ConvertToJson(j) + + + If clear_lb Then MsgBox ("clear") + Me.load_mbox + Me.load_array + +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 + +Sub new_part() + +End Sub + + +Private Sub UserForm_Initialize() + +End Sub diff --git a/VBA/fpvt.frx b/VBA/fpvt.frx new file mode 100644 index 0000000..06c36ed Binary files /dev/null and b/VBA/fpvt.frx differ diff --git a/VBA/handler.bas b/VBA/handler.bas new file mode 100644 index 0000000..20df27e --- /dev/null +++ b/VBA/handler.bas @@ -0,0 +1,643 @@ +Attribute VB_Name = "handler" +Option Explicit + +Public sql As String +Public jsql As String +Public scenario As String +Public sc() As Variant +Public x As New TheBigOne +Public wapi As New Windows_API +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....." + + 'data = x.SHTp_Get("data", 1, 1, True) + 'Call x.TBLp_Aggregate(data, True, True, True, Array(1, 3), Array("S", "S"), Array(30)) + 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 + .WaitForResponse + wr = .ResponseText + 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(rep As String) + + Dim req As New WinHttp.WinHttpRequest + Dim wapi As New Windows_API + Dim wr As String + Dim json As Object + Dim i As Long + Dim j As Long + Dim doc As String + Dim res() As Variant + Dim str() As String + + doc = "{""quota_rep"":""" & rep & """}" + + With req + .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All + .Open "GET", handler.server & "/get_pool", True + .SetRequestHeader "Content-Type", "application/json" + .Send doc + .WaitForResponse + wr = .ResponseText + End With + + If Mid(wr, 1, 1) <> "{" Then + MsgBox (wr) + Exit Sub + End If + Set json = JsonConverter.ParseJson(wr) + ReDim res(json("x").Count, 33) + + For i = 1 To UBound(res, 1) + res(i, 0) = json("x")(i)("bill_cust_descr") + res(i, 1) = json("x")(i)("billto_group") + res(i, 2) = json("x")(i)("ship_cust_descr") + res(i, 3) = json("x")(i)("shipto_group") + res(i, 4) = json("x")(i)("quota_rep_descr") + res(i, 5) = json("x")(i)("director") + res(i, 6) = json("x")(i)("segm") + res(i, 7) = json("x")(i)("substance") + res(i, 8) = json("x")(i)("chan") + res(i, 9) = json("x")(i)("chansub") + res(i, 10) = json("x")(i)("part_descr") + res(i, 11) = json("x")(i)("part_group") + res(i, 12) = json("x")(i)("branding") + res(i, 13) = json("x")(i)("majg_descr") + res(i, 14) = json("x")(i)("ming_descr") + res(i, 15) = json("x")(i)("majs_descr") + res(i, 16) = json("x")(i)("mins_descr") + res(i, 17) = json("x")(i)("order_season") + res(i, 18) = json("x")(i)("order_month") + res(i, 19) = json("x")(i)("ship_season") + res(i, 20) = json("x")(i)("ship_month") + res(i, 21) = json("x")(i)("request_season") + res(i, 22) = json("x")(i)("request_month") + res(i, 23) = json("x")(i)("promo") + res(i, 24) = json("x")(i)("value_loc") + res(i, 25) = json("x")(i)("value_usd") + res(i, 26) = json("x")(i)("cost_loc") + res(i, 27) = json("x")(i)("cost_usd") + res(i, 28) = json("x")(i)("units") + res(i, 29) = json("x")(i)("version") + res(i, 30) = json("x")(i)("iter") + res(i, 31) = json("x")(i)("logid") + res(i, 32) = json("x")(i)("tag") + res(i, 33) = json("x")(i)("comment") + Next i + + 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" + + Set json = Nothing + + ReDim str(UBound(res, 1), UBound(res, 2)) + + Worksheets("data").Cells.ClearContents + Call x.SHTp_DumpVar(res, "data", 1, 1, False, True, True) + + +End Sub + +Sub pull_rep() + + openf.Show + +End Sub + + + +Function request_adjust(doc As String, ByRef fail As Boolean) As Object + + 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 + + If doc = "" Then + fail = True + 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 = Sheets("config").Cells(1, 2) + + With req + .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All + .Open "POST", server & "/" & json("type"), True + .SetRequestHeader "Content-Type", "application/json" + .Send doc + .WaitForResponse + wr = .ResponseText + End With + + If Mid(wr, 2, 5) = "error" Then + MsgBox (wr) + fail = True + Exit Function + End If + + If Mid(wr, 1, 6) = "" Then + MsgBox (wr) + fail = True + Exit Function + End If + + If Mid(wr, 1, 6) = " "" + handler.basis(j) = Sheets("config").Cells(2, i) + j = j + 1 + i = i + 1 + Loop + ReDim Preserve handler.basis(j - 1) + '---baseline----------------------------------------------------------------- + ReDim handler.baseline(100) + i = 2 + j = 0 + Do While Sheets("config").Cells(3, i) <> "" + handler.baseline(j) = Sheets("config").Cells(3, i) + j = j + 1 + i = i + 1 + Loop + ReDim Preserve handler.baseline(j - 1) + '---adjustments----------------------------------------------------------------- + ReDim handler.adjust(100) + i = 2 + j = 0 + Do While Sheets("config").Cells(4, i) <> "" + handler.adjust(j) = Sheets("config").Cells(4, i) + j = j + 1 + i = i + 1 + Loop + ReDim Preserve handler.adjust(j - 1) + '---plan version-------------------------------------------------------------- + handler.plan = Sheets("config").Cells(9, 2) + +End Sub + +Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant) + + Dim j As Object + Dim i As Integer + Dim r As Long + Dim sh As Worksheet + Set sh = Sheets("_month") + + Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}") + sh.Cells(1, 16) = JsonConverter.ConvertToJson(j) + + For i = 0 To 12 + '------------volume------------------- + sh.Cells(i + 1, 1) = co_num(pkg(i, 1), 0) + sh.Cells(i + 1, 2) = co_num(pkg(i, 2), 0) + sh.Cells(i + 1, 3) = co_num(pkg(i, 3), 0) + sh.Cells(i + 1, 4) = 0 + sh.Cells(i + 1, 5) = co_num(pkg(i, 4), 0) + + '------------value---------------------- + sh.Cells(i + 1, 11) = co_num(pkg(i, 5), 0) + sh.Cells(i + 1, 12) = co_num(pkg(i, 6), 0) + sh.Cells(i + 1, 13) = co_num(pkg(i, 7), 0) + sh.Cells(i + 1, 14) = 0 + sh.Cells(i + 1, 15) = co_num(pkg(i, 8), 0) + + '-------------price---------------------- + If i > 0 Then + '--prior-- + If co_num(pkg(i, 1), 0) = 0 Then + sh.Cells(i + 1, 6) = 0 + Else + sh.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 sh.Cells(i, 7) <> 0 Then + sh.Cells(i + 1, 7) = sh.Cells(i, 7) + Else + If pkg(13, 1) + pkg(13, 2) = 0 Then + sh.Cells(i + 1, 7) = 0 + Else + sh.Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2)) + End If + End If + Else + sh.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 + sh.Cells(i + 1, 8) = 0 + Else + sh.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-- + sh.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 sh.Cells(i, 10) <> 0 Then + sh.Cells(i + 1, 10) = sh.Cells(i, 10) + Else + If pkg(13, 1) + pkg(13, 2) = 0 Then + sh.Cells(i + 1, 10) = 0 + Else + sh.Cells(i + 1, 10) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2)) + End If + End If + Else + sh.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4) + End If + + End If + + Next i + + 'scenario + Sheets("_month").Range("R1:S1000").ClearContents + For i = 0 To UBound(handler.sc, 1) + sh.Cells(i + 1, 18) = handler.sc(i, 0) + sh.Cells(i + 1, 19) = handler.sc(i, 1) + Next i + + 'basket + sh.Range("U1:AC100000").ClearContents + Call x.SHTp_DumpVar(basket, "_month", 1, 21, False, False, True) + Call x.SHTp_DumpVar(basket, "_month", 1, 26, False, False, True) + Sheets("config").Cells(5, 2) = 0 + Sheets("config").Cells(6, 2) = 0 + Sheets("config").Cells(7, 2) = 0 + + months.load_sheet + + +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 Integer + Dim j As Integer + Dim res() As Variant + + If doc = "" Then + fail = True + Exit Function + End If + + server = Sheets("config").Cells(1, 2) + + With req + .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All + .Open "GET", server & "/list_changes", True + .SetRequestHeader "Content-Type", "application/json" + .Send doc + .WaitForResponse + wr = .ResponseText + 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, 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 Integer + Dim j As Integer + 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 + .WaitForResponse + wr = .ResponseText + End With + + Set json = JsonConverter.ParseJson(wr) + logid = json("x")(1)("id") + + '---------loop through and get a list of each row that needs deleted?----- + + Set ds = Sheets("data") + + j = 0 + For i = 1 To 100 + If ds.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 + While ds.Cells(i, 1) <> "" + If ds.Cells(i, j) = logid Then + ds.Rows(i).Delete + Else + i = i + 1 + End If + Wend + + + +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 = Sheets("config").Cells(1, 2) + + With req + .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All + .Open "GET", server & "/swap_fit", True + .SetRequestHeader "Content-Type", "application/json" + .Send doc + .WaitForResponse + wr = .ResponseText + 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/VBA/months.cls b/VBA/months.cls new file mode 100644 index 0000000..ac822ec --- /dev/null +++ b/VBA/months.cls @@ -0,0 +1,1043 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "months" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + +Private x As New TheBigOne +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 dumping As Boolean +Private vedit As String +Private adjust() As Object +Private jtext() As Variant +Private basejson As Object +Private rollback As Boolean +Private scenario() As Variant +Private orig As Range +Private basket_touch As Range +Private showbasket As Boolean +Private np As Object 'json dedicated to new part scenario +Private b() As Variant 'holds basket +Private did_load_config As Boolean + + + +Private Sub cbMTAG_Change() + + + +End Sub + +Private Sub sbMPP_Change() + Dim m As Worksheet + Dim i As Long + + Application.ScreenUpdating = False + + dumping = True + + Set m = Sheets("month") + m.Cells(19, 11) = sbMPP.value / 100 + For i = 6 To 17 + m.Cells(i, 11) = (m.Cells(i, 9)) * m.Cells(19, 11) + Next i + + Me.mvp_adj + + dumping = False + + Application.ScreenUpdating = True +End Sub + + +Private Sub sbMPV_Change() + Dim m As Worksheet + Dim i As Long + + Application.ScreenUpdating = False + + dumping = True + + Set m = Sheets("month") + m.Cells(19, 5) = sbMPV.value / 100 + For i = 6 To 17 + If m.Cells(i, 5) <> "" Then + m.Cells(i, 5) = (m.Cells(i, 3)) * m.Cells(19, 5) + End If + Next i + + dumping = False + + Call Me.mvp_adj + + + Application.ScreenUpdating = True +End Sub + + + +Private Sub tbMCOM_Change() + +End Sub + +Private Sub Worksheet_Change(ByVal Target As Range) + + '---this needs checked prior to dumping check becuase % increase spinners are flagged as dumps + If Not did_load_config Then + Call handler.load_config + did_load_config = True + End If + + If Not dumping Then + + If Not Intersect(Target, Range("A1:R18")) Is Nothing Then + If Target.Columns.Count > 1 Then + MsgBox ("you can only change one column at a time - your change will be undone") + dumping = True + Application.Undo + dumping = False + Exit Sub + End If + End If + + If Not Intersect(Target, Range("E6:E17")) Is Nothing Then Call Me.mvp_adj + If Not Intersect(Target, Range("F6:F17")) Is Nothing Then Call Me.mvp_set + If Not Intersect(Target, Range("K6:K17")) Is Nothing Then Call Me.mvp_adj + If Not Intersect(Target, Range("L6:L17")) Is Nothing Then Call Me.mvp_set + If Not Intersect(Target, Range("Q6:Q17")) Is Nothing Then Call Me.ms_adj + If Not Intersect(Target, Range("R6:R17")) Is Nothing Then Call Me.ms_set + + If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then + Set basket_touch = Target + Call Me.get_edit_basket + Set basket_touch = Nothing + End If + + End If +End Sub + +Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) + + + If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then + Cancel = True + Call Me.basket_pick(Target) + Target.Select + End If + +End Sub + + +Sub picker_shortcut() + + If Not Intersect(Selection, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then + Call Me.basket_pick(Selection) + End If + +End Sub + +Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) + + If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then + Cancel = True + Call Me.basket_pick(Target) + Target.Select + 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 + Call Me.get_sheet + + 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 + + Me.crunch_array + Me.build_json + Me.set_sheet + + +End Sub + +Sub mvp_adj() + + Dim i As Integer + Call Me.get_sheet + + 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 + + Me.crunch_array + Me.build_json + Me.set_sheet + + +End Sub + +Sub ms_set() + +On Error GoTo errh + + Dim i As Integer + Call Me.get_sheet + Dim vp As String + vp = Sheets("month").Range("Q2") + + 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)) + Select Case vp + Case "volume" + If co_num(price(i, 5), 0) = 0 Then + MsgBox ("price cannot be -0- and also have sales - your change will be undone") + dumping = True + Application.Undo + dumping = False + Exit Sub + End If + 'reset price to original - delete these lines if a cascading effect is desired + 'price(i, 4) = 0 + 'price(i, 5) = price(i, 2) + price(i, 3) + 'calc volume change on original price + units(i, 5) = sales(i, 5) / price(i, 5) + units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3)) + Case "price" + If co_num(units(i, 5), 0) = 0 Then + MsgBox ("volume cannot be -0- and also have sales - your change will be undone") + dumping = True + Application.Undo + dumping = 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)) + Case Else + MsgBox ("error forcing sales with no offset specified - your change will be undone") + dumping = True + Application.Undo + dumping = False + Exit Sub + End Select + End If + Next i + + Me.crunch_array + Me.build_json + Me.set_sheet + +errh: + If Err.Number <> 0 Then rollback = True + + +End Sub + +Sub ms_adj() + + Dim i As Integer + Call Me.get_sheet + Dim vp As String + vp = Sheets("month").Range("Q2") + + 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) + Select Case vp + Case "volume" + If co_num(price(i, 5), 0) = 0 Then + MsgBox ("price cannot be -0- and also have sales - your change will be undone") + dumping = True + Application.Undo + dumping = False + Exit Sub + End If + 'reset price to original + 'price(i, 4) = 0 + 'price(i, 5) = price(i, 2) + price(i, 3) + 'calc volume change on original price + units(i, 5) = sales(i, 5) / price(i, 5) + units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3)) + Case "price" + If co_num(units(i, 5), 0) = 0 Then + MsgBox ("volume cannot be -0- and also have sales - your change will be undone") + dumping = True + Application.Undo + dumping = 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)) + Case Else + MsgBox ("error forcing sales with no offset specified - your change will be undone") + dumping = True + Application.Undo + dumping = False + Exit Sub + End Select + End If + Next i + + Me.crunch_array + Me.build_json + Me.set_sheet + + +End Sub + + +Sub get_sheet() + + Dim i As Integer + + units = Range("B6:F17") + price = Range("H6:L17") + sales = Range("N6:R17") + tunits = Range("B18:F18") + tprice = Range("H18:L18") + tsales = Range("N18:R18") + ReDim adjust(12) + Set basejson = JsonConverter.ParseJson(Sheets("_month").Range("P1").FormulaR1C1) + +End Sub + +Sub set_sheet() + + Dim i As Integer + + dumping = True + + Range("B6:F17") = units + Range("H6:L17") = price + Range("N6:R17") = sales + Range("B18:F18").FormulaR1C1 = tunits + Range("H18:L18").FormulaR1C1 = tprice + Range("N18:R18").FormulaR1C1 = tsales + Range("T6:U18").ClearContents + Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("R1")), "month", 6, 20, False, False, False) + 'Sheets("month").Range("B32:Q5000").ClearContents + + If Me.newpart Then + Sheets("_month").Range("P2:P13").ClearContents + Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np) + Else + For i = 1 To 12 + Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) + Next i + End If + + dumping = False + +End Sub + +Sub load_sheet() + + units = Sheets("_month").Range("A2:E13").FormulaR1C1 + price = Sheets("_month").Range("F2:J13").FormulaR1C1 + sales = Sheets("_month").Range("K2:O13").FormulaR1C1 + scenario = Sheets("_month").Range("R1:S13").FormulaR1C1 + tunits = Range("B18:F18") + tprice = Range("H18:L18") + tsales = Range("N18:R18") + 'reset basket + Sheets("_month").Range("U1:X10000").ClearContents + Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("Z1")), "_month", 1, 21, False, False, False) + ReDim adjust(12) + Call Me.crunch_array + Call Me.set_sheet + Call Me.print_basket + Call Me.set_format + did_load_config = False + +End Sub + +Sub set_format() + + Dim prices As Range + Dim price_adj As Range + Dim price_set As Range + Dim vol As Range + Dim vol_adj As Range + Dim vol_set As Range + Dim val As Range + Dim val_adj As Range + Dim val_set As Range + + Set prices = Sheets("month").Range("H6:L17") + Set price_adj = Sheets("month").Range("K6:K17") + Set price_set = Sheets("month").Range("L6:L17") + + Set vol = Sheets("month").Range("B6:F17") + Set vol_adj = Sheets("month").Range("E6:E17") + Set vol_set = Sheets("month").Range("F6:F17") + + Set val = Sheets("month").Range("N6:R17") + Set val_adj = Sheets("month").Range("Q6:Q17") + Set val_set = Sheets("month").Range("R6:R17") + + Call Me.format_price(prices) + Call Me.set_border(prices) + Call Me.fill_yellow(price_adj) + Call Me.fill_none(price_set) + + Call Me.format_number(vol) + Call Me.set_border(vol) + Call Me.fill_yellow(vol_adj) + Call Me.fill_none(vol_set) + + Call Me.format_number(val) + Call Me.set_border(val) + Call Me.fill_yellow(val_adj) + Call Me.fill_none(val_set) + +End Sub + +Sub set_border(ByRef targ As Range) + + targ.Borders(xlDiagonalDown).LineStyle = xlNone + targ.Borders(xlDiagonalUp).LineStyle = xlNone + With targ.Borders(xlEdgeLeft) + .LineStyle = xlContinuous + .ColorIndex = 0 + .TintAndShade = 0 + .Weight = xlThin + End With + With targ.Borders(xlEdgeTop) + .LineStyle = xlContinuous + .ColorIndex = 0 + .TintAndShade = 0 + .Weight = xlThin + End With + With targ.Borders(xlEdgeBottom) + .LineStyle = xlContinuous + .ColorIndex = 0 + .TintAndShade = 0 + .Weight = xlThin + End With + With targ.Borders(xlEdgeRight) + .LineStyle = xlContinuous + .ColorIndex = 0 + .TintAndShade = 0 + .Weight = xlThin + End With + With targ.Borders(xlInsideVertical) + .LineStyle = xlContinuous + .ColorIndex = 0 + .TintAndShade = 0 + .Weight = xlThin + End With + With targ.Borders(xlInsideHorizontal) + .LineStyle = xlContinuous + .ColorIndex = 0 + .TintAndShade = 0 + .Weight = xlThin + End With + +End Sub + +Sub fill_yellow(ByRef Target As Range) + + With Target.Interior + .Pattern = xlSolid + .PatternColorIndex = xlAutomatic + .ThemeColor = xlThemeColorAccent4 + .TintAndShade = 0.799981688894314 + .PatternTintAndShade = 0 + End With + +End Sub + +Sub fill_grey(ByRef Target As Range) + + + With Target.Interior + .Pattern = xlSolid + .PatternColorIndex = xlAutomatic + .ThemeColor = xlThemeColorDark1 + .TintAndShade = -0.149998474074526 + .PatternTintAndShade = 0 + End With + +End Sub + +Sub fill_none(ByRef Target As Range) + + With Target.Interior + .Pattern = xlNone + .TintAndShade = 0 + .PatternTintAndShade = 0 + End With + +End Sub + +Sub format_price(ByRef Target As Range) + + Target.NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)" + +End Sub + +Sub format_number(ByRef Target As Range) + + Target.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)" + +End Sub + +Sub build_json() + + Dim i As Long + Dim j As Long + Dim pos As Long + Dim o As Object + Dim m As Object + Dim list As Object + + ReDim handler.basis(100) + i = 2 + j = 0 + Do While Sheets("config").Cells(2, i) <> "" + handler.basis(j) = Sheets("config").Cells(2, i) + j = j + 1 + i = i + 1 + Loop + ReDim Preserve handler.basis(j - 1) + + 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""]") + np("source") = "adj" + np("type") = "new_basket" + np("tag") = cbMTAG.text + 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(Worksheets("month").Cells(5 + 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 + If Round(price(pos, 5), 8) <> Round(tprice(1, 2) + tprice(1, 3), 8) Then + 'if the target price is diferent from the average and a month is being added + adjust(pos)("type") = "addmonth_vp" + Else + 'if the target price is the same as average and a month is being added + '--ignore above comment and always use add month_vp + adjust(pos)("type") = "addmonth_vp" + End If + adjust(pos)("month") = Worksheets("month").Cells(5 + 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") = Worksheets("month").Cells(5 + 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") = Worksheets("month").Range("B33").value + 'np("basket") = x.json_from_table(b, "basket", False) + 'get the basket from the sheet + b = Worksheets("_month").Range("U1").CurrentRegion.value + Set m = JsonConverter.ParseJson(x.json_from_table(b, "basket", False)) + If UBound(b, 1) <= 2 Then + Set np("basket") = JsonConverter.ParseJson("[" & x.json_from_table(b, "basket", False) & "]") + Else + Set np("basket") = m("basket") + End If + End If + + If Me.newpart Then + Sheets("_month").Range("P2:P13").ClearContents + Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np) + Else + For i = 1 To 12 + Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) + Next i + End If + +End Sub + +Sub crunch_array() + + 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() + + Sheets("Orders").Select + +End Sub + +Sub reset() + + + Call Me.load_sheet + +End Sub + +Sub switch_basket() + + + If Sheets("config").Cells(6, 2) = 1 Then + Sheets("config").Cells(6, 2) = 0 + Else + Sheets("config").Cells(6, 2) = 1 + End If + + Call Me.print_basket + + +End Sub + +Sub print_basket() + + 'Sheets("config").Cells(6, 2) = 1 + If Sheets("config").Cells(6, 2) = 0 Then + dumping = True + Worksheets("month").Range("B32:Q10000").ClearContents + Rows("20:31").Hidden = False + dumping = False + Exit Sub + End If + + Dim i As Long + Dim basket() As Variant + basket = x.SHTp_get_block(Sheets("_month").Range("U1")) + + dumping = True + + Worksheets("month").Range("B32:Q10000").ClearContents + For i = 1 To UBound(basket, 1) + Sheets("month").Cells(31 + i, 2) = basket(i, 1) + Sheets("month").Cells(31 + i, 6) = basket(i, 2) + Sheets("month").Cells(31 + i, 12) = basket(i, 3) + Sheets("month").Cells(31 + i, 17) = basket(i, 4) + Next i + + Rows("21:31").Hidden = True + + dumping = False + +End Sub + + +Sub basket_pick(ByRef Target As Range) + + Dim i As Long + + + build.part = Sheets("month").Cells(Target.row, 2) + build.bill = rev_cust(Sheets("month").Cells(Target.row, 6)) + build.ship = rev_cust(Sheets("month").Cells(Target.row, 12)) + build.useval = False + build.Show + + If build.useval Then + dumping = True + 'if an empty row is selected, force it to be the next open slot + If Sheets("month").Cells(Target.row, 2) = "" Then + Do Until Sheets("month").Cells(Target.row + i, 2) <> "" + i = i - 1 + Loop + i = i + 1 + End If + + + Sheets("month").Cells(Target.row + i, 2) = build.cbPart.value + Sheets("month").Cells(Target.row + i, 6) = rev_cust(build.cbBill.value) + Sheets("month").Cells(Target.row + i, 12) = rev_cust(build.cbShip.value) + dumping = False + Set basket_touch = Selection + Call Me.get_edit_basket + Set basket_touch = Nothing + + End If + Target.Select + + +End Sub + +Sub get_edit_basket() + + Dim i As Long + Dim mix As Double + Dim touch_mix As Double + Dim untouched As Long + Dim touch() As Boolean + + 'ReDim b(basket_rows, 3) + + i = 0 + Do Until Worksheets("month").Cells(33 + i, 2) = "" + i = i + 1 + Loop + i = i - 1 + + ReDim b(i, 3) + ReDim touch(i) + untouched = i + 1 + + i = 0 + mix = 0 + Do Until Worksheets("month").Cells(33 + i, 2) = "" + b(i, 0) = Worksheets("month").Cells(33 + i, 2) + b(i, 1) = Worksheets("month").Cells(33 + i, 6) + b(i, 2) = Worksheets("month").Cells(33 + i, 12) + b(i, 3) = Worksheets("month").Cells(33 + i, 17) + If b(i, 3) = "" Then b(i, 3) = 0 + mix = mix + b(i, 3) + If Not Intersect(basket_touch, Worksheets("month").Cells(33 + i, 17)) Is Nothing Then + touch_mix = touch_mix + b(i, 3) + touch(i) = True + untouched = untouched - 1 + End If + i = i + 1 + Loop + + 'evaluate mix changes and force to 100 + For i = 0 To UBound(b, 1) + If Not touch(i) Then + If mix - touch_mix = 0 Then + b(i, 3) = (1 - mix) / untouched + Else + b(i, 3) = b(i, 3) + b(i, 3) * (1 - mix) / (mix - touch_mix) + End If + End If + Next i + + dumping = True + + 'put the mix plug back on the the sheet + For i = 0 To UBound(b, 1) + Worksheets("month").Cells(33 + i, 17) = b(i, 3) + Next i + + dumping = False + + Worksheets("_month").Range("U2:X5000").ClearContents + Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True) + + If Me.newpart Then + Me.build_json + End If + + + + +End Sub + + +Sub post_adjust() + + Dim i As Long + Dim fail As Boolean + Dim adjust As Object + Dim jdoc As String + + If Me.newpart Then + Set adjust = JsonConverter.ParseJson(Sheets("_month").Cells(2, 16)) + adjust("message") = Me.tbMCOM.text + adjust("tag") = Me.cbMTAG.text + jdoc = JsonConverter.ConvertToJson(adjust) + Call handler.request_adjust(jdoc, fail) + If fail Then Exit Sub + Else + For i = 2 To 13 + If Sheets("_month").Cells(i, 16) <> "" Then + Set adjust = JsonConverter.ParseJson(Sheets("_month").Cells(i, 16)) + adjust("message") = Me.tbMCOM.text + adjust("tag") = Me.cbMTAG.text + jdoc = JsonConverter.ConvertToJson(adjust) + Call handler.request_adjust(jdoc, fail) + If fail Then Exit Sub + End If + Next i + End If + + Sheets("Orders").Select + 'Worksheets("month").Visible = xlHidden + +End Sub + +Sub build_new() + + Worksheets("config").Cells(5, 2) = 1 + Dim i As Long + Dim j As Long + Dim basket() As Variant + Dim m() As Variant + + dumping = True + + m = Sheets("_month").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 + + Worksheets("_month").Range("A2:O13") = m + + Worksheets("_month").Range("U2:X1000").ClearContents + Worksheets("_month").Range("Z2:AC1000").ClearContents + Worksheets("_month").Range("R2:S1000").ClearContents + Call Me.load_sheet + 'Call Me.set_sheet + 'Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("R1")), "month", 6, 20, False, False, False) + + basket = x.SHTp_get_block(Worksheets("_month").Range("U1")) + Sheets("month").Cells(32, 2) = basket(1, 1) + Sheets("month").Cells(32, 6) = basket(1, 2) + Sheets("month").Cells(32, 12) = basket(1, 3) + Sheets("month").Cells(32, 17) = basket(1, 4) + Call Me.print_basket + + dumping = 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 = x.SHTp_Get("_month", 1, 27, True) + If Not x.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 + + dumping = True + + Worksheets("month").Range("B33:Q10000").ClearContents + + For i = 1 To UBound(cust, 2) + Sheets("month").Cells(32 + i, 2) = part.cbPart.value + Sheets("month").Cells(32 + i, 6) = cust(0, i) + Sheets("month").Cells(32 + i, 12) = cust(1, i) + Sheets("month").Cells(32 + i, 17) = CDbl(cust(2, i)) + Next i + + Sheets("config").Cells(7, 2) = 1 + + '------copy revised basket to _month storage--------------------------------------------------- + + i = 0 + Do Until Worksheets("month").Cells(33 + i, 2) = "" + i = i + 1 + Loop + i = i - 1 + If i = -1 Then i = 0 + ReDim b(i, 3) + i = 0 + Do Until Worksheets("month").Cells(33 + i, 2) = "" + b(i, 0) = Worksheets("month").Cells(33 + i, 2) + b(i, 1) = Worksheets("month").Cells(33 + i, 6) + b(i, 2) = Worksheets("month").Cells(33 + i, 12) + b(i, 3) = Worksheets("month").Cells(33 + i, 17) + If b(i, 3) = "" Then b(i, 3) = 0 + i = i + 1 + Loop + Worksheets("_month").Range("U2:AC10000").ClearContents + Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True) + Call x.SHTp_DumpVar(b, "_month", 2, 26, False, False, True) + + '------reset volume to copy base to forecsat and clear base------------------------------------ + + units = Sheets("_month").Range("A2:E13").FormulaR1C1 + price = Sheets("_month").Range("F2:J13").FormulaR1C1 + sales = Sheets("_month").Range("K2:O13").FormulaR1C1 + tunits = Range("B18:F18") + tprice = Range("H18:L18") + tsales = Range("N18:R18") + ReDim adjust(12) + Set basejson = JsonConverter.ParseJson(Sheets("_month").Range("P1").FormulaR1C1) + For i = 1 To 12 + 'volume + units(i, 5) = units(i, 2) + units(i, 4) = units(i, 2) + units(i, 1) = 0 + units(i, 2) = 0 + units(i, 3) = 0 + 'sales + sales(i, 5) = sales(i, 2) + sales(i, 4) = sales(i, 2) + sales(i, 1) = 0 + sales(i, 2) = 0 + sales(i, 3) = 0 + 'price + price(i, 5) = price(i, 2) + price(i, 4) = price(i, 2) + price(i, 1) = 0 + price(i, 2) = 0 + price(i, 3) = 0 + Next i + Call Me.crunch_array + Call Me.build_json + Call Me.set_sheet + + '-------------push revised arrays back to _month, not revertable------------------------------- + + Worksheets("_month").Range("A2:E13") = units + Worksheets("_month").Range("F2:J13") = price + Worksheets("_month").Range("K2:o13") = sales + + + 'force basket to show to demonstrate the part was changed + Sheets("config").Cells(6, 2) = 1 + Call Me.print_basket + dumping = False + +End Sub + +Function newpart() As Boolean + + If Worksheets("config").Cells(7, 2) = 1 Then + newpart = True + Else + newpart = False + End If + +End Function + + diff --git a/VBA/openf.frm b/VBA/openf.frm new file mode 100644 index 0000000..3d82d41 --- /dev/null +++ b/VBA/openf.frm @@ -0,0 +1,51 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} openf + Caption = "Open a Forecast" + ClientHeight = 2025 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 3825 + 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() + + Application.StatusBar = "Retrieving data for " & cbDSM.value & "....." + + openf.Caption = "retrieving data......" + Call handler.pg_main_workset(cbDSM.value) + Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh + Application.StatusBar = False + openf.Hide + +End Sub + +Private Sub UserForm_Activate() + + 'handler.server = "http://192.168.1.69:3000" + handler.server = Sheets("config").Cells(1, 2) + + Dim x As New TheBigOne + Dim d() As String + + openf.Caption = "Select a DSM" + d = x.SHTp_Get("reps", 1, 1, True) + + For i = 1 To UBound(d, 2) + Call cbDSM.AddItem(d(0, i)) + Next i + + +End Sub + diff --git a/VBA/openf.frx b/VBA/openf.frx new file mode 100644 index 0000000..07ce6a6 Binary files /dev/null and b/VBA/openf.frx differ diff --git a/VBA/part.frm b/VBA/part.frm new file mode 100644 index 0000000..f678245 --- /dev/null +++ b/VBA/part.frm @@ -0,0 +1,48 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} part + Caption = "Part Picker" + ClientHeight = 1080 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 8100 + 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 + +Public part As String +Public bill As String +Public ship As String +Public useval As Boolean +Option Explicit + + +Private Sub cbPart_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) + + Select Case KeyCode + Case 13 + useval = True + Me.Hide + Case 27 + useval = False + Me.Hide + End Select + +End Sub + + + +Private Sub UserForm_Activate() + + useval = False + + cbPart.list = Application.transpose(Worksheets("mdata").Range("A2:A26267")) + + +End Sub + + diff --git a/VBA/part.frx b/VBA/part.frx new file mode 100644 index 0000000..9fccdf8 Binary files /dev/null and b/VBA/part.frx differ diff --git a/VBA/pivot.cls b/VBA/pivot.cls new file mode 100644 index 0000000..31a08c8 --- /dev/null +++ b/VBA/pivot.cls @@ -0,0 +1,122 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "pivot" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + +Private Sub Worksheet_Activate() + +End Sub + +Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) + + If Intersect(Target, ActiveSheet.Range("b8:v100000")) Is Nothing Then + Exit Sub + End If + + On Error GoTo nopiv + + If Target.Cells.PivotTable Is Nothing 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 pt As PivotTable + Dim pf As PivotField + Dim pi As PivotItem + Dim wapi As New Windows_API + + 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) + Set pt = Target.Cells.PivotCell.PivotTable + + 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 + +nopiv: + +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/VBA/pivot1.cls b/VBA/pivot1.cls new file mode 100644 index 0000000..fae47b1 --- /dev/null +++ b/VBA/pivot1.cls @@ -0,0 +1,122 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "pivot1" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + +Private Sub Worksheet_Activate() + +End Sub + +Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) + + If Intersect(Target, ActiveSheet.Range("b7:v100000")) Is Nothing Then + Exit Sub + End If + + On Error GoTo nopiv + + If Target.Cells.PivotTable Is Nothing 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 pt As PivotTable + Dim pf As PivotField + Dim pi As PivotItem + Dim wapi As New Windows_API + + 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) + Set pt = Target.Cells.PivotCell.PivotTable + + 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 + +nopiv: + +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 + +