diff --git a/PriceLists.bas b/PriceLists.bas index 78e3924..6d674a1 100644 --- a/PriceLists.bas +++ b/PriceLists.bas @@ -476,21 +476,20 @@ Sub build_customer_files() Dim x As New TheBigOne Dim pl() As String + Dim pln() As String + Dim plf() As String Dim fc() As String Dim nwb As Workbook Dim fcwb As Workbook Dim nws As Worksheet + Dim nnws As Worksheet + Dim nfws As Worksheet Dim fcws As Worksheet Dim filepath As String - Dim c As Range - Dim i As Long - Dim j As Long - Dim last As Long - Dim lastcol As Long Dim clist() As String - Dim curr As String Dim plev As String Dim effdate As Date + Dim segment_regex As String '----------------------pick price level--------------------------------------------------------------------- login.Caption = "PostgreSQL Login" @@ -509,88 +508,184 @@ Sub build_customer_files() effdate = CDate(pricelevel.tbEddDate.text) filepath = pricelevel.tbPATH & "\" & plev - '---------------------get full code list-------------------------------------------------------------------- - fc = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_fullcode_cust('" & plev & "', '" & effdate & "'::date)", False, 20000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm") - If fc(0, 0) <> "Currency" Then - MsgBox (fc(0, 0)) - Exit Sub + If pricelevel.chbFULLCODE Then + '---------------------get full code list-------------------------------------------------------------------- + fc = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_fullcode_cust('" & plev & "', '" & effdate & "'::date)", False, 20000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm") + If fc(0, 0) <> "Currency" Then + MsgBox (fc(0, 0)) + Exit Sub + End If + + '---------------------create new workbook------------------------------------------------------------------- + If UBound(fc, 2) = 0 Then + MsgBox ("no full code list data for " & plev) + Exit Sub + End If + Application.ScreenUpdating = False + Set fcwb = Application.Workbooks.Add + fcwb.Activate + Set fcws = fcwb.Sheets(1) + fcws.Activate + 'fcws.Cells.NumberFormat = "@" 'format all cells to text so pasted text values are not cast to numeric + Call x.SHTp_Dump(fc, fcws.Name, 1, 1, False, True, 6, 7, 8, 9, 10, 11, 12, 13, 14) + Rows("1:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove + + '--------------------format full code------------------------------------------------------------------------ + Application.CutCopyMode = False + fcws.ListObjects.Add(xlSrcRange, fcws.Cells(3, 1).CurrentRegion, , xlYes).Name = "Full Code Listing" + fcws.ListObjects("Full Code Listing").TableStyle = "TableStyleMedium21" + fcws.Cells.Font.Name = "Courier New" + fcws.Cells.Font.Size = 10 + With fcws.Rows(3) + .WrapText = True + .RowHeight = 40.5 + End With + fcws.Columns("A").ColumnWidth = 9.43 + fcws.Columns("B").ColumnWidth = 20 + fcws.Columns("C:D").ColumnWidth = 35 + fcws.Columns("E").ColumnWidth = 21.5 + fcws.Columns("F").ColumnWidth = 3.71 + fcws.Columns("G").ColumnWidth = 9.43 + fcws.Columns("G").NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)" + fcws.Columns("H").ColumnWidth = 7.14 + fcws.Columns("I:P").ColumnWidth = 14 + fcws.Columns("I:P").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)" + fcws.Columns("O").ColumnWidth = 10.57 + fcws.Columns("O").NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)" + Rows("3:3").NumberFormat = "General" + fcws.Activate + ActiveWindow.DisplayGridlines = False + Rows("4:4").Select + ActiveWindow.FreezePanes = True + fcws.ListObjects("Full Code Listing").ShowAutoFilter = False + + '---------------------logo---------------------------------------------------------------------------------- + fcws.Rows("1:2").RowHeight = 28.5 + fcws.Cells(1, 1).Select + fcws.Pictures.Insert("https://hc-companies.com/wp-content/themes/hc-companies/images/logo.svg").Select + Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft + Selection.ShapeRange.IncrementLeft 2 + Selection.ShapeRange.IncrementTop 2 + ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes.Item(1), address:="https://hc-companies.com/" + fcws.Cells(1, 4).value = "Distributor Price List - Effective " & Format(effdate, "MM/DD/YYYY") + fcws.Name = "Full Code Listing" + fcws.Cells(3, 1).Select End If - - '---------------------create new workbook------------------------------------------------------------------- - If UBound(fc, 2) = 0 Then - MsgBox ("no full code list data for " & plev) - Exit Sub - End If - Application.ScreenUpdating = False - Set fcwb = Application.Workbooks.Add - fcwb.Activate - Set fcws = fcwb.Sheets(1) - fcws.Activate - 'fcws.Cells.NumberFormat = "@" 'format all cells to text so pasted text values are not cast to numeric - Call x.SHTp_Dump(fc, fcws.Name, 1, 1, False, True, 6, 7, 8, 9, 10, 11, 12, 13, 14) - Rows("1:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove - - '--------------------format full code------------------------------------------------------------------------ - Application.CutCopyMode = False - fcws.ListObjects.Add(xlSrcRange, fcws.Cells(3, 1).CurrentRegion, , xlYes).Name = "Full Code Listing" - fcws.ListObjects("Full Code Listing").TableStyle = "TableStyleMedium21" - fcws.Cells.Font.Name = "Courier New" - fcws.Cells.Font.Size = 10 - With fcws.Rows(3) - .WrapText = True - .RowHeight = 40.5 - End With - fcws.Columns("A").ColumnWidth = 9.43 - fcws.Columns("B").ColumnWidth = 20 - fcws.Columns("C:D").ColumnWidth = 35 - fcws.Columns("E").ColumnWidth = 21.5 - fcws.Columns("F").ColumnWidth = 3.71 - fcws.Columns("G").ColumnWidth = 9.43 - fcws.Columns("G").NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)" - fcws.Columns("H").ColumnWidth = 7.14 - fcws.Columns("I:P").ColumnWidth = 14 - fcws.Columns("I:P").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)" - fcws.Columns("O").ColumnWidth = 10.57 - fcws.Columns("O").NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)" - Rows("3:3").NumberFormat = "General" - fcws.Activate - ActiveWindow.DisplayGridlines = False - Rows("4:4").Select - ActiveWindow.FreezePanes = True - fcws.ListObjects("Full Code Listing").ShowAutoFilter = False - - '---------------------logo---------------------------------------------------------------------------------- - fcws.Rows("1:2").RowHeight = 28.5 - fcws.Cells(1, 1).Select - fcws.Pictures.Insert("https://hc-companies.com/wp-content/themes/hc-companies/images/logo.svg").Select - Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft - Selection.ShapeRange.IncrementLeft 2 - Selection.ShapeRange.IncrementTop 2 - ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes.Item(1), address:="https://hc-companies.com/" - fcws.Cells(1, 4).value = "Distributor Price List - Effective " & Format(effdate, "MM/DD/YYYY") - fcws.Name = "Full Code Listing" - fcws.Cells(3, 1).Select 'Application.ScreenUpdating = True 'Exit Sub - '---------------------get price list------------------------------------------------------------------------ - pl = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "')", False, 2000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm") - If pl(0, 0) <> "Product" Then - MsgBox (pl(0, 0)) - Exit Sub - End If - '---------------------create new workbook------------------------------------------------------------------- Set nwb = Application.Workbooks.Add nwb.Activate Set nws = nwb.Sheets(1) + segment_regex = "G|N|F" + + '---------------------get price list------------------------------------------------------------------------ + If pricelevel.chbNURSERY Then + pln = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "', '^N')", False, 2000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm") + If pln(0, 0) <> "Product" Then + MsgBox (pln(0, 0)) + Exit Sub + End If + If UBound(pln, 2) > 21 Then + segment_regex = "^F|^G" + Set nnws = nwb.Sheets.Add(, nws) + nnws.Name = "Price List - Nursery" + Call paste_pretty(pln, nnws, effdate) + End If + End If + + If pricelevel.chbFIBER Then + plf = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','^F')", False, 2000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm") + If plf(0, 0) <> "Product" Then + MsgBox (plf(0, 0)) + Exit Sub + End If + If UBound(plf, 2) > 21 Then + If segment_regex = "^F|^G" Then + segment_regex = "^G" + Else + segment_regex = "^G|^N" + End If + Set nfws = nwb.Sheets.Add(, nws) + nfws.Name = "Price List - Fiber" + Call paste_pretty(plf, nfws, effdate) + End If + End If + + pl = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','" & segment_regex & "')", False, 2000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm") + If pl(0, 0) <> "Product" Then + MsgBox (pl(0, 0)) + Exit Sub + End If + If UBound(pl, 2) > 21 Then + nws.Name = "Price list" + Call paste_pretty(pl, nws, effdate) + Else + nws.Delete + End If + + Application.ScreenUpdating = True + + '--------------------save file-------------------------------------------------------------------------------- + 'Dim fd As Object + 'Set fd = Application.FileDialog(msoFileDialogFolderPicker) + 'fd.Show + 'If fd.SelectedItems.Count = 0 Then Exit Sub + With CreateObject("Scripting.FileSystemObject") + If Not .FolderExists(filepath) Then .CreateFolder filepath + End With + Application.DisplayAlerts = True + nwb.Activate + + Dim wb As Workbook + For Each wb In Workbooks + If wb.Name = "HC Companies Distributor Price List.xlsx" Then + If MsgBox("already have a price list open, close it?", vbOKCancel) Then + Workbooks("HC Companies Distributor Price List.xlsx").Close + Exit For + Else + Exit Sub + End If + End If + Next wb + + If pricelevel.tbPATH.text <> "" Then nwb.SaveAs Filename:=filepath & "\HC Companies Distributor Price List.xlsx" + + For Each wb In Workbooks + If wb.Name = "HC FullCode List.xlsx" Then + If MsgBox("already have a full code list open, close it?", vbOKCancel) Then + Workbooks("HC FullCode List.xlsx").Close + Exit For + Else + Exit Sub + End If + End If + Next wb + + If Not (fcwb Is Nothing) Then + If pricelevel.tbPATH.text <> "" Then fcwb.SaveAs Filename:=filepath & "\HC FullCode List.xlsx" + End If + + +End Sub + +Sub paste_pretty(ByRef pl() As String, ByRef nws As Worksheet, ByVal effdate As Date) + + Dim c As Range + Dim i As Long + Dim last As Long + Dim lastcol As Long + Dim j As Long + Dim curr As String + nws.Activate nws.Cells.NumberFormat = "@" '---------------------format to numeric if selected--------------------------------------------------------- If pricelevel.cbNUMERIC Then - Call x.SHTp_Dump(pl, nws.Name, 1, 1, False, True, 9, 12, 15, 10, 13, 16) - Rows("1:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove + Call tbo.SHTp_Dump(pl, nws.Name, 1, 1, False, True, 9, 12, 15, 10, 13, 16) + nws.Rows("1:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove nws.Columns(10).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)" nws.Columns(13).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)" nws.Columns(16).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)" @@ -602,7 +697,7 @@ Sub build_customer_files() nws.Columns(16).ColumnWidth = 13 nws.Rows(5).NumberFormat = "@" Else - Call x.SHTp_Dump(pl, nws.Name, 5, 1, False, True) + Call tbo.SHTp_Dump(pl, nws.Name, 5, 1, False, True) nws.Columns(10).ColumnWidth = 10.57 nws.Columns(13).ColumnWidth = 10.57 nws.Columns(16).ColumnWidth = 10.57 @@ -729,9 +824,9 @@ Sub build_customer_files() Next i '--------------------print header data-------------------------------------------------------------------------- - pl = x.TBLp_Transpose(pl) - Call x.TBLp_FilterSingle(pl, 20, "", False) - Call x.TBLp_Group(pl, True, x.ARRAYp_MakeInteger(20)) + pl = tbo.TBLp_Transpose(pl) + Call tbo.TBLp_FilterSingle(pl, 20, "", False) + Call tbo.TBLp_Group(pl, True, tbo.ARRAYp_MakeInteger(20)) If UBound(pl, 2) > 1 Then '---somehow multiple currencies involved---- MsgBox ("multiple currencies") @@ -747,54 +842,14 @@ Sub build_customer_files() End Select End If nws.Cells(2, 3).value = "Distributor Price List (" & curr & ") - Effective " & Format(effdate, "MM/DD/YYYY") - nws.Name = "Price List" nws.Cells(5, 1).Select Call print_setup(nws, last) nws.Columns("R:V").Delete - - Application.ScreenUpdating = True - - '--------------------save file-------------------------------------------------------------------------------- - 'Dim fd As Object - 'Set fd = Application.FileDialog(msoFileDialogFolderPicker) - 'fd.Show - 'If fd.SelectedItems.Count = 0 Then Exit Sub - With CreateObject("Scripting.FileSystemObject") - If Not .FolderExists(filepath) Then .CreateFolder filepath - End With - Application.DisplayAlerts = True - nwb.Activate - - Dim wb As Workbook - For Each wb In Workbooks - If wb.Name = "HC Companies Distributor Price List.xlsx" Then - If MsgBox("already have a price list open, close it?", vbOKCancel) Then - Workbooks("HC Companies Distributor Price List.xlsx").Close - Exit For - Else - Exit Sub - End If - End If - Next wb - - If pricelevel.tbPATH.text <> "" Then nwb.SaveAs Filename:=filepath & "\HC Companies Distributor Price List.xlsx" - - For Each wb In Workbooks - If wb.Name = "HC FullCode List.xlsx" Then - If MsgBox("already have a full code list open, close it?", vbOKCancel) Then - Workbooks("HC FullCode List.xlsx").Close - Exit For - Else - Exit Sub - End If - End If - Next wb - - If pricelevel.tbPATH.text <> "" Then fcwb.SaveAs Filename:=filepath & "\HC FullCode List.xlsx" - + + End Sub Function rrange(ByRef sheet As Worksheet, start_row As Long, end_row As Long, start_col As Long, end_col As Long) As Range diff --git a/pricelevel.frx b/pricelevel.frx index 8d9dbee..c0ba771 100644 Binary files a/pricelevel.frx and b/pricelevel.frx differ