diff --git a/VBA/JsonDebugPrint.bas b/VBA/JsonDebugPrint.bas index 93d29db..12e284f 100644 --- a/VBA/JsonDebugPrint.bas +++ b/VBA/JsonDebugPrint.bas @@ -3,8 +3,8 @@ Option Explicit Public Sub TestPrintJSON() - PrintJSON ParseJSON("[1,2,3]") - PrintJSON ParseJSON("[{""a"":123,""b"":[56,7,78]}]") + PrintJSON ParseJson("[1,2,3]") + PrintJSON ParseJson("[{""a"":123,""b"":[56,7,78]}]") End Sub ' This is definitely NOT a pretty printer. It was written merely as a debugging diff --git a/VBA/TheBigOne.cls b/VBA/TheBigOne.cls deleted file mode 100644 index cb811a7..0000000 --- a/VBA/TheBigOne.cls +++ /dev/null @@ -1,2730 +0,0 @@ -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/ThisWorkbook.cls b/VBA/ThisWorkbook.cls new file mode 100644 index 0000000..71a3598 --- /dev/null +++ b/VBA/ThisWorkbook.cls @@ -0,0 +1,9 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ThisWorkbook" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True diff --git a/VBA/Windows_API.cls b/VBA/Windows_API.cls deleted file mode 100644 index bec7900..0000000 --- a/VBA/Windows_API.cls +++ /dev/null @@ -1,247 +0,0 @@ -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 index 30ee2db..054208b 100644 --- a/VBA/build.frm +++ b/VBA/build.frm @@ -19,9 +19,6 @@ 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 @@ -67,14 +64,9 @@ Private Sub UserForm_Activate() 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 - - + cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.value + cbBill.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value + cbShip.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value End Sub diff --git a/VBA/build.frx b/VBA/build.frx index d9f12a0..1cfd023 100644 Binary files a/VBA/build.frx and b/VBA/build.frx differ diff --git a/VBA/changes.frm b/VBA/changes.frm index f296776..a8504fe 100644 --- a/VBA/changes.frm +++ b/VBA/changes.frm @@ -56,17 +56,12 @@ 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) + x = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & shData.Cells(2, 5) & """}}", fail) If fail Then Me.Hide Exit Sub @@ -86,8 +81,7 @@ Private Sub UserForm_Activate() 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") + Call Utils.frmListBoxHeader(Me.lbHEAD, Me.lbHist, "Modifier", "Owner", "When", "Tag", "Comment", "Sales", "id") ' make it pretty @@ -126,7 +120,7 @@ Sub delete_selected() End If Next i - Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh + shOrders.PivotTables("ptOrders").PivotCache.Refresh Me.lbHist.clear Me.Hide diff --git a/VBA/changes.frx b/VBA/changes.frx index c2b84e9..a6bea63 100644 Binary files a/VBA/changes.frx and b/VBA/changes.frx differ diff --git a/VBA/fpvt.frm b/VBA/fpvt.frm index 395c35f..15be6ba 100644 --- a/VBA/fpvt.frm +++ b/VBA/fpvt.frm @@ -129,10 +129,11 @@ End Sub Private Sub butMAdjust_Click() Dim i As Integer - + Dim fail As Boolean + For i = 1 To 12 If month(i, 10) <> "" Then - Call handler.request_adjust(CStr(month(i, 10))) + Call handler.request_adjust(CStr(month(i, 10)), fail) End If Next i @@ -149,14 +150,14 @@ End Sub Private Sub cbGoSheet_Click() - Worksheets("month").tbMCOM.text = "" - Worksheets("month").sbMPV.value = 0 - Worksheets("month").sbMPP.value = 0 + shMonthView.tbMCOM.text = "" + shMonthView.sbMPV.value = 0 + shMonthView.sbMPP.value = 0 Me.Hide - months.cbMTAG.value = "" - Worksheets("month").Visible = xlSheetVisible - Sheets("month").Select + shMonthView.cbMTAG.value = "" + shMonthView.Visible = xlSheetVisible + shMonthView.Select End Sub @@ -229,10 +230,10 @@ Private Sub cbPLIST_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift 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) + vtable = Utils.ARRAYp_TransposeVar(vSwap) + vtable = Utils.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit") + vtable = Utils.ARRAYp_TransposeVar(vtable) + ptable = Utils.json_from_table_zb(vtable, "rows", True, False) Set jswap("swap") = JsonConverter.ParseJson(ptable) jswap("scenario")("version") = handler.plan @@ -265,14 +266,14 @@ Private Sub dbGETSWAP_Click() lbSWAP.list = vSwap 'Call x.frmListBoxHeader(lbSWAPH, lbSWAP, "Original", "Sales", "Replacement", "Fit") - cbPLIST.list = Application.transpose(Worksheets("mdata").Range("A2:A26267")) + cbPLIST.list = shSupportingData.ListObjects("ITEM").DataBodyRange.value '---------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) + vtable = Utils.ARRAYp_TransposeVar(vSwap) + vtable = Utils.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit") + vtable = Utils.ARRAYp_TransposeVar(vtable) + ptable = Utils.json_from_table_zb(vtable, "rows", True, False) Set jswap("swap") = JsonConverter.ParseJson(ptable) jswap("scenario")("version") = handler.plan @@ -464,10 +465,6 @@ Private Sub opPlugVol_Click() End If End Sub -Private Sub pickSWAP_Change() - -End Sub - Private Sub sbpd_Change() tbpd.value = sbpd.value @@ -592,13 +589,13 @@ Private Sub UserForm_Activate() Dim ok As Boolean Dim tags() As Variant - Me.Caption = "Forecast Adjust " & Worksheets("config").Cells(8, 2) + Me.Caption = "Forecast Adjust " & shConfig.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") + Call Utils.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection") Me.lheader = "Ready" @@ -633,7 +630,6 @@ Private Sub UserForm_Activate() For i = 1 To sp("package")("totals").Count Select Case sp("package")("totals")(i)("order_season") - '--------------changed this based on "totals" section---------- Case 2024 Select Case Me.iter_def(sp("package")("totals")(i)("iter")) Case "baseline" @@ -753,7 +749,7 @@ Private Sub UserForm_Activate() cust(i, 3) = "" Next i - Call x.frmListBoxHeader(lbCUSTH, lbCUST, "Bill-To", "Replace", "Ship-To", "Replace") + Call Utils.frmListBoxHeader(lbCUSTH, lbCUST, "Bill-To", "Replace", "Ship-To", "Replace") '-------------load tags------------------------------- @@ -763,9 +759,9 @@ Private Sub UserForm_Activate() tags(i - 1, 0) = sp("package")("tags")(i) Next i cbTAG.list = tags - Sheets("month").cbMTAG.list = tags + shMonthView.cbMTAG.list = tags cbTAG.ListRows = UBound(tags, 1) + 1 - months.cbMTAG.ListRows = UBound(tags, 1) + 1 + shMonthView.cbMTAG.ListRows = UBound(tags, 1) + 1 End If '----------reset spinner buttons---------------------- @@ -777,11 +773,11 @@ Private Sub UserForm_Activate() 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) + pickSWAP.list = shSupportingData.ListObjects("MOLD").DataBodyRange.value + cbBT.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value + cbST.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value lbCUST.list = cust - Call x.frmListBoxHeader(Me.lbSWAPH, Me.lbSWAP, "Original", "Sales", "Replacement", "Fit") + Call Utils.frmListBoxHeader(Me.lbSWAPH, Me.lbSWAP, "Original", "Sales", "Replacement", "Fit") '---------price volume radio button colors---------- If opPlugPrice.value = True Then @@ -899,10 +895,10 @@ 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) + vtable = Utils.ARRAYp_TransposeVar(vtable) + vtable = Utils.ARRAYp_zerobased_addheader(vtable, "bill", "bill_r", "ship", "ship_r") + vtable = Utils.ARRAYp_TransposeVar(vtable) + ptable = Utils.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 @@ -1358,12 +1354,3 @@ Function iter_def(ByVal iter As String) As String 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 index c263e68..d2ccee9 100644 Binary files a/VBA/fpvt.frx and b/VBA/fpvt.frx differ diff --git a/VBA/handler.bas b/VBA/handler.bas index 20df27e..3d632e5 100644 --- a/VBA/handler.bas +++ b/VBA/handler.bas @@ -5,8 +5,6 @@ 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 @@ -21,8 +19,6 @@ 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 @@ -78,7 +74,6 @@ 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 @@ -181,8 +176,8 @@ Sub pg_main_workset(rep As String) ReDim str(UBound(res, 1), UBound(res, 2)) - Worksheets("data").Cells.ClearContents - Call x.SHTp_DumpVar(res, "data", 1, 1, False, True, True) + shData.Cells.ClearContents + Call Utils.SHTp_DumpVar(res, shData.Name, 1, 1, False, True, True) End Sub @@ -214,7 +209,7 @@ Function request_adjust(doc As String, ByRef fail As Boolean) As Object 'json("stamp") = Format(Now, "yyyy-mm-dd hh:mm:ss") 'doc = JsonConverter.ConvertToJson(doc) - server = Sheets("config").Cells(1, 2) + server = shConfig.Cells(1, 2) With req .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All @@ -311,16 +306,16 @@ Function request_adjust(doc As String, ByRef fail As Boolean) As Object ' Next i i = 1 - Do Until Sheets("data").Cells(i, 1) = "" + Do Until shData.Cells(i, 1) = "" i = i + 1 Loop - Call x.SHTp_DumpVar(res, "data", i, 1, False, False, True) + Call Utils.SHTp_DumpVar(res, shData.Name, i, 1, False, False, True) - 'Call x.SHTp_Dump(str, "data", CLng(i), 1, False, False, 28, 29, 30, 31, 32) + 'Call Utils.SHTp_Dump(str, shData.Name, CLng(i), 1, False, False, 28, 29, 30, 31, 32) - Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh + shOrders.PivotTables("ptOrders").PivotCache.Refresh End Function @@ -329,13 +324,13 @@ Sub load_config() Dim i As Integer Dim j As Integer '----server to use--------------------------------------------------------- - handler.server = Sheets("config").Cells(1, 2) + handler.server = shConfig.Cells(1, 2) '---basis----------------------------------------------------------------- ReDim handler.basis(100) i = 2 j = 0 - Do While Sheets("config").Cells(2, i) <> "" - handler.basis(j) = Sheets("config").Cells(2, i) + Do While shConfig.Cells(2, i) <> "" + handler.basis(j) = shConfig.Cells(2, i) j = j + 1 i = i + 1 Loop @@ -344,8 +339,8 @@ Sub load_config() ReDim handler.baseline(100) i = 2 j = 0 - Do While Sheets("config").Cells(3, i) <> "" - handler.baseline(j) = Sheets("config").Cells(3, i) + Do While shConfig.Cells(3, i) <> "" + handler.baseline(j) = shConfig.Cells(3, i) j = j + 1 i = i + 1 Loop @@ -354,14 +349,14 @@ Sub load_config() ReDim handler.adjust(100) i = 2 j = 0 - Do While Sheets("config").Cells(4, i) <> "" - handler.adjust(j) = Sheets("config").Cells(4, i) + Do While shConfig.Cells(4, i) <> "" + handler.adjust(j) = shConfig.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) + handler.plan = shConfig.Cells(9, 2) End Sub @@ -370,104 +365,105 @@ 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) + With shMonthUpdate - 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) + Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}") + .Cells(1, 16) = JsonConverter.ConvertToJson(j) - '------------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 + For i = 0 To 12 + '------------volume------------------- + .Cells(i + 1, 1) = co_num(pkg(i, 1), 0) + .Cells(i + 1, 2) = co_num(pkg(i, 2), 0) + .Cells(i + 1, 3) = co_num(pkg(i, 3), 0) + .Cells(i + 1, 4) = 0 + .Cells(i + 1, 5) = co_num(pkg(i, 4), 0) - '--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) + '------------value---------------------- + .Cells(i + 1, 11) = co_num(pkg(i, 5), 0) + .Cells(i + 1, 12) = co_num(pkg(i, 6), 0) + .Cells(i + 1, 13) = co_num(pkg(i, 7), 0) + .Cells(i + 1, 14) = 0 + .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 + .Cells(i + 1, 6) = 0 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 + .Cells(i + 1, 6) = pkg(i, 5) / pkg(i, 1) 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) + + '--base-- + If co_num(pkg(i, 2), 0) = 0 Then + 'if there is no monthly base volume, + 'then use the prior price, if there was no prior price, + 'then inherit the average price for the year before current adjustments + If .Cells(i, 7) <> 0 Then + .Cells(i + 1, 7) = .Cells(i, 7) + Else + If pkg(13, 1) + pkg(13, 2) = 0 Then + .Cells(i + 1, 7) = 0 + Else + .Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2)) + End If + End If Else - 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 + .Cells(i + 1, 7) = pkg(i, 6) / pkg(i, 2) End If - Else - sh.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4) + + '--adjust-- + If (pkg(i, 3) + pkg(i, 2)) = 0 Or pkg(i, 2) = 0 Then + .Cells(i + 1, 8) = 0 + Else + .Cells(i + 1, 8) = (Round(pkg(i, 7), 10) + Round(pkg(i, 6), 10)) / (Round(pkg(i, 3), 10) + Round(pkg(i, 2), 10)) - (Round(pkg(i, 6), 10) / Round(pkg(i, 2), 10)) + End If + + '--current adjust-- + .Cells(i + 1, 9) = 0 + + '--forecast-- + If co_num(pkg(i, 4), 0) = 0 Then + 'if there is no monthly base volume, + 'then use the prior price, if there was no prior price, + 'then inherit the average price for the year before current adjustments + If .Cells(i, 10) <> 0 Then + .Cells(i + 1, 10) = .Cells(i, 10) + Else + If pkg(13, 1) + pkg(13, 2) = 0 Then + .Cells(i + 1, 10) = 0 + Else + .Cells(i + 1, 10) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2)) + End If + End If + Else + .Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4) + End If + End If - End If + Next i - 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 - + 'scenario + .Range("R1:S1000").ClearContents + For i = 0 To UBound(handler.sc, 1) + .Cells(i + 1, 18) = handler.sc(i, 0) + .Cells(i + 1, 19) = handler.sc(i, 1) + Next i + + 'basket + .Range("U1:AC100000").ClearContents + Call Utils.SHTp_DumpVar(basket, .Name, 1, 21, False, False, True) + Call Utils.SHTp_DumpVar(basket, .Name, 1, 26, False, False, True) + shConfig.Cells(5, 2) = 0 + shConfig.Cells(6, 2) = 0 + shConfig.Cells(7, 2) = 0 + + shMonthView.load_sheet + End With + End Sub Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant @@ -495,7 +491,7 @@ Function list_changes(doc As String, ByRef fail As Boolean) As Variant() Exit Function End If - server = Sheets("config").Cells(1, 2) + server = shConfig.Cells(1, 2) With req .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All @@ -559,12 +555,10 @@ Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant( 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 + If shData.Cells(1, i) = "logid" Then j = i Exit For End If @@ -577,15 +571,15 @@ Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant( 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 - - + With shData + While .Cells(i, 1) <> "" + If .Cells(i, j) = logid Then + .Rows(i).Delete + Else + i = i + 1 + End If + Wend + End With End Function @@ -610,7 +604,7 @@ Function get_swap_fit(doc As String, ByRef fail As Boolean) As Variant() Exit Function End If - server = Sheets("config").Cells(1, 2) + server = shConfig.Cells(1, 2) With req .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All diff --git a/VBA/openf.frm b/VBA/openf.frm index 3d82d41..f532528 100644 --- a/VBA/openf.frm +++ b/VBA/openf.frm @@ -25,7 +25,7 @@ Private Sub cbOK_Click() openf.Caption = "retrieving data......" Call handler.pg_main_workset(cbDSM.value) - Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh + shOrders.PivotTables("ptOrders").PivotCache.Refresh Application.StatusBar = False openf.Hide @@ -34,18 +34,10 @@ 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 + handler.server = shConfig.Cells(1, 2) 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 - + cbDSM.list = shSupportingData.ListObjects("DSM").DataBodyRange.value End Sub diff --git a/VBA/openf.frx b/VBA/openf.frx index 07ce6a6..e38e596 100644 Binary files a/VBA/openf.frx and b/VBA/openf.frx differ diff --git a/VBA/part.frm b/VBA/part.frm index f678245..50960e0 100644 --- a/VBA/part.frm +++ b/VBA/part.frm @@ -39,9 +39,7 @@ End Sub Private Sub UserForm_Activate() useval = False - - cbPart.list = Application.transpose(Worksheets("mdata").Range("A2:A26267")) - + cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.value End Sub diff --git a/VBA/part.frx b/VBA/part.frx index 9fccdf8..4ddcb68 100644 Binary files a/VBA/part.frx and b/VBA/part.frx differ diff --git a/VBA/shConfig.cls b/VBA/shConfig.cls new file mode 100644 index 0000000..f5f7841 --- /dev/null +++ b/VBA/shConfig.cls @@ -0,0 +1,9 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shConfig" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True diff --git a/VBA/shData.cls b/VBA/shData.cls new file mode 100644 index 0000000..760b10c --- /dev/null +++ b/VBA/shData.cls @@ -0,0 +1,9 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shData" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True diff --git a/VBA/shMonthUpdate.cls b/VBA/shMonthUpdate.cls new file mode 100644 index 0000000..fee51b7 --- /dev/null +++ b/VBA/shMonthUpdate.cls @@ -0,0 +1,9 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shMonthUpdate" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True diff --git a/VBA/months.cls b/VBA/shMonthView.cls similarity index 76% rename from VBA/months.cls rename to VBA/shMonthView.cls index ac822ec..e869af3 100644 --- a/VBA/months.cls +++ b/VBA/shMonthView.cls @@ -2,14 +2,13 @@ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END -Attribute VB_Name = "months" +Attribute VB_Name = "shMonthView" 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 @@ -31,13 +30,6 @@ 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 @@ -46,7 +38,7 @@ Private Sub sbMPP_Change() dumping = True - Set m = Sheets("month") + Set m = shMonthView m.Cells(19, 11) = sbMPP.value / 100 For i = 6 To 17 m.Cells(i, 11) = (m.Cells(i, 9)) * m.Cells(19, 11) @@ -68,7 +60,7 @@ Private Sub sbMPV_Change() dumping = True - Set m = Sheets("month") + Set m = shMonthView m.Cells(19, 5) = sbMPV.value / 100 For i = 6 To 17 If m.Cells(i, 5) <> "" Then @@ -117,7 +109,7 @@ Private Sub Worksheet_Change(ByVal Target As Range) 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 + If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And shConfig.Cells(6, 2) = 1 Then Set basket_touch = Target Call Me.get_edit_basket Set basket_touch = Nothing @@ -129,7 +121,7 @@ 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 + If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And shConfig.Cells(6, 2) = 1 Then Cancel = True Call Me.basket_pick(Target) Target.Select @@ -140,7 +132,7 @@ End Sub Sub picker_shortcut() - If Not Intersect(Selection, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then + If Not Intersect(Selection, Range("B33:Q1000")) Is Nothing And shConfig.Cells(6, 2) = 1 Then Call Me.basket_pick(Selection) End If @@ -148,7 +140,7 @@ 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 + If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And shConfig.Cells(6, 2) = 1 Then Cancel = True Call Me.basket_pick(Target) Target.Select @@ -228,7 +220,7 @@ On Error GoTo errh Dim i As Integer Call Me.get_sheet Dim vp As String - vp = Sheets("month").Range("Q2") + vp = shMonthView.Range("Q2") For i = 1 To 12 If sales(i, 5) = "" Then sales(i, 5) = 0 @@ -284,7 +276,7 @@ Sub ms_adj() Dim i As Integer Call Me.get_sheet Dim vp As String - vp = Sheets("month").Range("Q2") + vp = shMonthView.Range("Q2") For i = 1 To 12 If sales(i, 4) = "" Then sales(i, 4) = 0 @@ -344,7 +336,7 @@ Sub get_sheet() tprice = Range("H18:L18") tsales = Range("N18:R18") ReDim adjust(12) - Set basejson = JsonConverter.ParseJson(Sheets("_month").Range("P1").FormulaR1C1) + Set basejson = JsonConverter.ParseJson(shMonthUpdate.Range("P1").FormulaR1C1) End Sub @@ -361,15 +353,15 @@ Sub set_sheet() 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 + Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("R1")), shMonthView.Name, 6, 20, False, False, False) + 'shMonthView.Range("B32:Q5000").ClearContents If Me.newpart Then - Sheets("_month").Range("P2:P13").ClearContents - Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np) + shMonthUpdate.Range("P2:P13").ClearContents + shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np) Else For i = 1 To 12 - Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) + shMonthUpdate.Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) Next i End If @@ -379,16 +371,16 @@ 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 + units = shMonthUpdate.Range("A2:E13").FormulaR1C1 + price = shMonthUpdate.Range("F2:J13").FormulaR1C1 + sales = shMonthUpdate.Range("K2:O13").FormulaR1C1 + scenario = shMonthUpdate.Range("R1:S13").FormulaR1C1 tunits = 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) + shMonthUpdate.Range("U1:X10000").ClearContents + Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("Z1")), shMonthUpdate.Name, 1, 21, False, False, False) ReDim adjust(12) Call Me.crunch_array Call Me.set_sheet @@ -410,17 +402,17 @@ Sub set_format() 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 prices = shMonthView.Range("H6:L17") + Set price_adj = shMonthView.Range("K6:K17") + Set price_set = shMonthView.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 vol = shMonthView.Range("B6:F17") + Set vol_adj = shMonthView.Range("E6:E17") + Set vol_set = shMonthView.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") + Set val = shMonthView.Range("N6:R17") + Set val_adj = shMonthView.Range("Q6:Q17") + Set val_set = shMonthView.Range("R6:R17") Call Me.format_price(prices) Call Me.set_border(prices) @@ -541,8 +533,8 @@ Sub build_json() ReDim handler.basis(100) i = 2 j = 0 - Do While Sheets("config").Cells(2, i) <> "" - handler.basis(j) = Sheets("config").Cells(2, i) + Do While shConfig.Cells(2, i) <> "" + handler.basis(j) = shConfig.Cells(2, i) j = j + 1 i = i + 1 Loop @@ -568,7 +560,7 @@ Sub build_json() 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)) + Set m(shMonthView.Cells(5 + pos, 1).value) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(o)) End If Else 'if something is changing @@ -585,7 +577,7 @@ Sub build_json() '--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)("month") = shMonthView.Cells(5 + pos, 1) adjust(pos)("qty") = units(pos, 4) adjust(pos)("amount") = sales(pos, 4) Else @@ -603,7 +595,7 @@ Sub build_json() 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) + adjust(pos)("scenario")("order_month") = shMonthView.Cells(5 + pos, 1) End If adjust(pos)("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") adjust(pos)("user") = Application.UserName @@ -616,24 +608,24 @@ Sub build_json() If Me.newpart Then Set np("months") = JsonConverter.ParseJson(JsonConverter.ConvertToJson(m)) - np("newpart") = Worksheets("month").Range("B33").value + np("newpart") = shMonthView.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)) + b = shMonthUpdate.Range("U1").CurrentRegion.value + Set m = JsonConverter.ParseJson(Utils.json_from_table(b, "basket", False)) If UBound(b, 1) <= 2 Then - Set np("basket") = JsonConverter.ParseJson("[" & x.json_from_table(b, "basket", False) & "]") + Set np("basket") = JsonConverter.ParseJson("[" & Utils.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) + shMonthUpdate.Range("P2:P13").ClearContents + shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np) Else For i = 1 To 12 - Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) + shMonthUpdate.Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) Next i End If @@ -689,12 +681,11 @@ End Sub Sub Cancel() - Sheets("Orders").Select + shOrders.Select End Sub Sub reset() - Call Me.load_sheet @@ -703,10 +694,10 @@ End Sub Sub switch_basket() - If Sheets("config").Cells(6, 2) = 1 Then - Sheets("config").Cells(6, 2) = 0 + If shConfig.Cells(6, 2) = 1 Then + shConfig.Cells(6, 2) = 0 Else - Sheets("config").Cells(6, 2) = 1 + shConfig.Cells(6, 2) = 1 End If Call Me.print_basket @@ -716,10 +707,10 @@ End Sub Sub print_basket() - 'Sheets("config").Cells(6, 2) = 1 - If Sheets("config").Cells(6, 2) = 0 Then + 'SHCONFIG.Cells(6, 2) = 1 + If shConfig.Cells(6, 2) = 0 Then dumping = True - Worksheets("month").Range("B32:Q10000").ClearContents + shMonthView.Range("B32:Q10000").ClearContents Rows("20:31").Hidden = False dumping = False Exit Sub @@ -727,16 +718,16 @@ Sub print_basket() Dim i As Long Dim basket() As Variant - basket = x.SHTp_get_block(Sheets("_month").Range("U1")) + basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1")) dumping = True - Worksheets("month").Range("B32:Q10000").ClearContents + shMonthView.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) + shMonthView.Cells(31 + i, 2) = basket(i, 1) + shMonthView.Cells(31 + i, 6) = basket(i, 2) + shMonthView.Cells(31 + i, 12) = basket(i, 3) + shMonthView.Cells(31 + i, 17) = basket(i, 4) Next i Rows("21:31").Hidden = True @@ -751,26 +742,26 @@ 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.part = shMonthView.Cells(Target.row, 2) + build.bill = rev_cust(shMonthView.Cells(Target.row, 6)) + build.ship = rev_cust(shMonthView.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) <> "" + If shMonthView.Cells(Target.row, 2) = "" Then + Do Until shMonthView.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) + shMonthView.Cells(Target.row + i, 2) = build.cbPart.value + shMonthView.Cells(Target.row + i, 6) = rev_cust(build.cbBill.value) + shMonthView.Cells(Target.row + i, 12) = rev_cust(build.cbShip.value) dumping = False Set basket_touch = Selection Call Me.get_edit_basket @@ -793,7 +784,7 @@ Sub get_edit_basket() 'ReDim b(basket_rows, 3) i = 0 - Do Until Worksheets("month").Cells(33 + i, 2) = "" + Do Until shMonthView.Cells(33 + i, 2) = "" i = i + 1 Loop i = i - 1 @@ -804,14 +795,14 @@ Sub get_edit_basket() 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) + Do Until shMonthView.Cells(33 + i, 2) = "" + b(i, 0) = shMonthView.Cells(33 + i, 2) + b(i, 1) = shMonthView.Cells(33 + i, 6) + b(i, 2) = shMonthView.Cells(33 + i, 12) + b(i, 3) = shMonthView.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 + If Not Intersect(basket_touch, shMonthView.Cells(33 + i, 17)) Is Nothing Then touch_mix = touch_mix + b(i, 3) touch(i) = True untouched = untouched - 1 @@ -834,13 +825,13 @@ Sub get_edit_basket() '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) + shMonthView.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) + shMonthUpdate.Range("U2:X5000").ClearContents + Call Utils.SHTp_DumpVar(b, shMonthUpdate.Name, 2, 21, False, False, True) If Me.newpart Then Me.build_json @@ -860,7 +851,7 @@ Sub post_adjust() Dim jdoc As String If Me.newpart Then - Set adjust = JsonConverter.ParseJson(Sheets("_month").Cells(2, 16)) + Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(2, 16)) adjust("message") = Me.tbMCOM.text adjust("tag") = Me.cbMTAG.text jdoc = JsonConverter.ConvertToJson(adjust) @@ -868,8 +859,8 @@ Sub post_adjust() 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)) + If shMonthUpdate.Cells(i, 16) <> "" Then + Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(i, 16)) adjust("message") = Me.tbMCOM.text adjust("tag") = Me.cbMTAG.text jdoc = JsonConverter.ConvertToJson(adjust) @@ -879,14 +870,14 @@ Sub post_adjust() Next i End If - Sheets("Orders").Select - 'Worksheets("month").Visible = xlHidden + shOrders.Select + 'shMonthView.Visible = xlHidden End Sub Sub build_new() - Worksheets("config").Cells(5, 2) = 1 + shConfig.Cells(5, 2) = 1 Dim i As Long Dim j As Long Dim basket() As Variant @@ -894,7 +885,7 @@ Sub build_new() dumping = True - m = Sheets("_month").Range("A2:O13").FormulaR1C1 + m = shMonthUpdate.Range("A2:O13").FormulaR1C1 For i = 1 To UBound(m, 1) For j = 1 To UBound(m, 2) @@ -902,20 +893,18 @@ Sub build_new() Next j Next i - Worksheets("_month").Range("A2:O13") = m + shMonthUpdate.Range("A2:O13") = m - Worksheets("_month").Range("U2:X1000").ClearContents - Worksheets("_month").Range("Z2:AC1000").ClearContents - Worksheets("_month").Range("R2:S1000").ClearContents + shMonthUpdate.Range("U2:X1000").ClearContents + shMonthUpdate.Range("Z2:AC1000").ClearContents + shMonthUpdate.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) + basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1")) + shMonthView.Cells(32, 2) = basket(1, 1) + shMonthView.Cells(32, 6) = basket(1, 2) + shMonthView.Cells(32, 12) = basket(1, 3) + shMonthView.Cells(32, 17) = basket(1, 4) Call Me.print_basket dumping = False @@ -934,8 +923,8 @@ Sub new_part() '---------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 + cust = Utils.SHTp_Get(shMonthUpdate.Name, 1, 27, True) + If Not Utils.TBLp_Aggregate(cust, True, True, True, Array(0, 1), Array("S", "S"), Array(2)) Then MsgBox ("error building customer mix") End If @@ -949,49 +938,49 @@ Sub new_part() dumping = True - Worksheets("month").Range("B33:Q10000").ClearContents + shMonthView.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)) + shMonthView.Cells(32 + i, 2) = part.cbPart.value + shMonthView.Cells(32 + i, 6) = cust(0, i) + shMonthView.Cells(32 + i, 12) = cust(1, i) + shMonthView.Cells(32 + i, 17) = CDbl(cust(2, i)) Next i - Sheets("config").Cells(7, 2) = 1 + shConfig.Cells(7, 2) = 1 '------copy revised basket to _month storage--------------------------------------------------- i = 0 - Do Until Worksheets("month").Cells(33 + i, 2) = "" + Do Until shMonthView.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) + Do Until shMonthView.Cells(33 + i, 2) = "" + b(i, 0) = shMonthView.Cells(33 + i, 2) + b(i, 1) = shMonthView.Cells(33 + i, 6) + b(i, 2) = shMonthView.Cells(33 + i, 12) + b(i, 3) = shMonthView.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) + shMonthUpdate.Range("U2:AC10000").ClearContents + Call Utils.SHTp_DumpVar(b, shMonthUpdate.Name, 2, 21, False, False, True) + Call Utils.SHTp_DumpVar(b, shMonthUpdate.Name, 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 + units = shMonthUpdate.Range("A2:E13").FormulaR1C1 + price = shMonthUpdate.Range("F2:J13").FormulaR1C1 + sales = shMonthUpdate.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) + Set basejson = JsonConverter.ParseJson(shMonthUpdate.Range("P1").FormulaR1C1) For i = 1 To 12 'volume units(i, 5) = units(i, 2) @@ -1018,13 +1007,13 @@ Sub new_part() '-------------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 + shMonthUpdate.Range("A2:E13") = units + shMonthUpdate.Range("F2:J13") = price + shMonthUpdate.Range("K2:o13") = sales 'force basket to show to demonstrate the part was changed - Sheets("config").Cells(6, 2) = 1 + shConfig.Cells(6, 2) = 1 Call Me.print_basket dumping = False @@ -1032,7 +1021,7 @@ End Sub Function newpart() As Boolean - If Worksheets("config").Cells(7, 2) = 1 Then + If shConfig.Cells(7, 2) = 1 Then newpart = True Else newpart = False diff --git a/VBA/pivot.cls b/VBA/shOrders.cls similarity index 88% rename from VBA/pivot.cls rename to VBA/shOrders.cls index 31a08c8..d301ae0 100644 --- a/VBA/pivot.cls +++ b/VBA/shOrders.cls @@ -2,26 +2,23 @@ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END -Attribute VB_Name = "pivot" +Attribute VB_Name = "shOrders" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = True Option Explicit -Private Sub Worksheet_Activate() - -End Sub - Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) - - If Intersect(Target, ActiveSheet.Range("b8:v100000")) Is Nothing Then + Dim pt As PivotTable + Set pt = ActiveSheet.PivotTables("ptOrders") + + Dim intersec As Range + Set intersec = Intersect(Target, pt.DataBodyRange) + + If intersec Is Nothing Then Exit Sub - End If - - On Error GoTo nopiv - - If Target.Cells.PivotTable Is Nothing Then + ElseIf intersec.address <> Target.address Then Exit Sub End If @@ -38,10 +35,8 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean 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 @@ -51,7 +46,6 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean Set cd = Target.Cells.PivotTable.ColumnFields ReDim handler.sc(ri.Count, 1) - Set pt = Target.Cells.PivotCell.PivotTable handler.sql = "" handler.jsql = "" @@ -69,8 +63,6 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean Call handler.load_config Call handler.load_fpvt - -nopiv: End Sub diff --git a/VBA/shSupportingData.cls b/VBA/shSupportingData.cls new file mode 100644 index 0000000..7ff049e --- /dev/null +++ b/VBA/shSupportingData.cls @@ -0,0 +1,9 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shSupportingData" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True diff --git a/VBA/pivot1.cls b/VBA/shWalk.cls similarity index 88% rename from VBA/pivot1.cls rename to VBA/shWalk.cls index fae47b1..1ba92cf 100644 --- a/VBA/pivot1.cls +++ b/VBA/shWalk.cls @@ -2,26 +2,22 @@ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END -Attribute VB_Name = "pivot1" +Attribute VB_Name = "shWalk" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = True Option Explicit -Private Sub Worksheet_Activate() - -End Sub - Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) - - If Intersect(Target, ActiveSheet.Range("b7:v100000")) Is Nothing Then + Dim pt As PivotTable + Set pt = ActiveSheet.PivotTables("ptWalk") + Dim intersec As Range + Set intersec = Intersect(Target, pt.DataBodyRange) + + If intersec Is Nothing Then Exit Sub - End If - - On Error GoTo nopiv - - If Target.Cells.PivotTable Is Nothing Then + ElseIf intersec.address <> Target.address Then Exit Sub End If @@ -38,10 +34,8 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean 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 @@ -51,7 +45,6 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean Set cd = Target.Cells.PivotTable.ColumnFields ReDim handler.sc(ri.Count, 1) - Set pt = Target.Cells.PivotCell.PivotTable handler.sql = "" handler.jsql = "" @@ -69,8 +62,6 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean Call handler.load_config Call handler.load_fpvt - -nopiv: End Sub