From c66e05c29e1d5e48c322a694bed795558f99f1e2 Mon Sep 17 00:00:00 2001 From: Paul Trowbridge Date: Wed, 18 May 2022 12:58:40 -0400 Subject: [PATCH] build full code list --- PriceLists.bas | 90 +++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 85 insertions(+), 5 deletions(-) diff --git a/PriceLists.bas b/PriceLists.bas index 43a0195..91903a8 100644 --- a/PriceLists.bas +++ b/PriceLists.bas @@ -373,7 +373,7 @@ PRICELIST_SHOW: '--------Open file------------- - If Not x.FILEp_CreateCSV(pricelist.tbPath.text & "\" & Replace(pl_code, ".", "_") & ".csv", ul) Then + If Not x.FILEp_CreateCSV(pricelist.tbPATH.text & "\" & Replace(pl_code, ".", "_") & ".csv", ul) Then MsgBox ("error") End If @@ -488,12 +488,15 @@ Function unpivot_current_sheet(ByRef lists() As String, ByRef pcol() As Long) As End Function -Sub build_pretty() +Sub build_customer_files() Dim x As New TheBigOne Dim pl() As String + Dim fc() As String Dim nwb As Workbook + Dim fcwb As Workbook Dim nws As Worksheet + Dim fcws As Worksheet Dim filepath As String Dim c As Range Dim i As Long @@ -506,6 +509,8 @@ Sub build_pretty() Dim effdate As Date '----------------------pick price level--------------------------------------------------------------------- + login.tbU = "report" + login.tbP = "report" login.Show If Not login.proceed Then Exit Sub Call pricelevel.repopulate @@ -517,7 +522,68 @@ Sub build_pretty() Exit Sub End If effdate = CDate(pricelevel.tbEddDate.text) - filepath = pricelevel.tbPath & "\" & plev + 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 + 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) + 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 = 13 + fcws.Columns("F").ColumnWidth = 3.7 + fcws.Columns("H").ColumnWidth = 7 + fcws.Columns("I:P").ColumnWidth = 14 + fcws.Columns("I:N").Style = "Comma" + fcws.Columns("G").Style = "Comma" + 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") @@ -563,7 +629,8 @@ Sub build_pretty() nws.Columns(14).ColumnWidth = 11.71 nws.Columns(17).ColumnWidth = 11.71 ActiveWindow.DisplayGridlines = False - nws.Cells.Font.Name = "Cascadia Code Light" + 'nws.Cells.Font.Name = "Cascadia Code Light" + nws.Cells.Font.Name = "Courier New" nws.Cells.Font.Size = 10 Rows("6:6").Select ActiveWindow.FreezePanes = True @@ -653,7 +720,7 @@ Sub build_pretty() End Select End If nws.Cells(2, 3).value = "Distributor Price List (" & curr & ") - Effective " & Format(effdate, "MM/DD/YYYY") - nws.Name = curr + nws.Name = "Price List" nws.Cells(5, 1).Select Call print_setup(nws, last) @@ -686,6 +753,19 @@ Sub build_pretty() Next wb 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 + + fcwb.SaveAs Filename:=filepath & "\HC FullCode List.xlsx" End Sub