pt/VBA
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

adjust page breaks based on row heights, export to pdf

Browse Source
This commit is contained in:
Paul Trowbridge 2022-06-29 17:12:00 -04:00
parent 48670f9ca7
commit 24b91e4fb5
1 changed files with 18 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
PriceLists.bas
View File

@ -490,6 +490,8 @@ Sub build_customer_files()
Dim plev As String
Dim effdate As Date
Dim segment_regex As String
Dim curr As String
Dim fname As String
'----------------------pick price level---------------------------------------------------------------------
login.Caption = "PostgreSQL Login"
@ -595,7 +597,7 @@ Sub build_customer_files()
segment_regex = "^F|^G|^P"
Set nnws = nwb.Sheets.Add(, nws)
nnws.Name = "Price List - Nursery"
Call paste_pretty(pln, nnws, effdate)
Call paste_pretty(pln, nnws, effdate, curr)
End If
End If
@ -613,7 +615,7 @@ Sub build_customer_files()
End If
Set nfws = nwb.Sheets.Add(, nws)
nfws.Name = "Price List - Fiber"
Call paste_pretty(plf, nfws, effdate)
Call paste_pretty(plf, nfws, effdate, curr)
End If
End If
@ -624,7 +626,7 @@ Sub build_customer_files()
End If
If UBound(pl, 2) > 21 Then
nws.Name = "Price list"
Call paste_pretty(pl, nws, effdate)
Call paste_pretty(pl, nws, effdate, curr)
Else
nws.Delete
End If
@ -642,11 +644,13 @@ Sub build_customer_files()
Application.DisplayAlerts = True
nwb.Activate
fname = "HC Companies Distributor Price List " & curr & ".xlsx"
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name = "HC Companies Distributor Price List.xlsx" Then
If wb.Name = fname Then
If MsgBox("already have a price list open, close it?", vbOKCancel) Then
Workbooks("HC Companies Distributor Price List.xlsx").Close
Workbooks(fname).Close
Exit For
Else
Exit Sub
@ -654,8 +658,11 @@ Sub build_customer_files()
End If
Next wb
If pricelevel.tbPATH.text <> "" Then nwb.SaveAs Filename:=filepath & "\HC Companies Distributor Price List.xlsx"
If pricelevel.tbPATH.text <> "" Then nwb.SaveAs Filename:=filepath & "\" & fname
fname = Replace(fname, "xlsx", "pdf")
nwb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=filepath & "\" & fname, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
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
@ -674,14 +681,13 @@ Sub build_customer_files()
End Sub
Sub paste_pretty(ByRef pl() As String, ByRef nws As Worksheet, ByVal effdate As Date)
Sub paste_pretty(ByRef pl() As String, ByRef nws As Worksheet, ByVal effdate As Date, ByRef curr As String)
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 = "@"
@ -739,7 +745,7 @@ Sub paste_pretty(ByRef pl() As String, ByRef nws As Worksheet, ByVal effdate As
nws.Columns(15).WrapText = True
nws.Columns(11).ColumnWidth = 11.71
nws.Columns(14).ColumnWidth = 11.71
nws.Columns(17).ColumnWidth = 11.71
nws.Columns(17).ColumnWidth = 13
ActiveWindow.DisplayGridlines = False
'nws.Cells.Font.Name = "Cascadia Code Light"
nws.Cells.Font.Name = "Courier New"
@ -1077,11 +1083,11 @@ Sub print_setup(sheet As Worksheet, last_row As Long)
'-------------------force a page break on color codes----------
j = 1
For i = 5 To last_row
If j = 60 Then
If j >= 810 Then
sheet.HPageBreaks.Add before:=sheet.Rows(i + 1)
j = 1
End If
'every 73 rows is a page break for current font
'every 73 rows is a page break for current font, but if a row is taller this needs accounted for
If sheet.Cells(i, 18) = "colors" And sheet.Cells(i - 1, 18) <> "colors" Then
sheet.HPageBreaks.Add before:=sheet.Rows(i)
j = 1
@ -1090,7 +1096,7 @@ Sub print_setup(sheet As Worksheet, last_row As Long)
sheet.HPageBreaks.Add before:=sheet.Rows(i)
j = 1
End If
j = j + 1
j = j + sheet.Rows(i).RowHeight
Next i
sheet.DisplayPageBreaks = False