include currency in name of full code file

convert fullcode to pdf
2023-05-22 12:07:26 -04:00 · 2023-05-22 11:41:09 -04:00
7 changed files with 141 additions and 104 deletions
--- a/FL.bas
+++ b/FL.bas
@ -1294,7 +1294,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
    
@ -1659,7 +1659,7 @@ Sub pricegroup_upload()
    Dim sql As String
    Selection.CurrentRegion.Select
    
-    sql = x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, True, "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "A", "A", "J")
+    sql = x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, True, "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "A", "A", "J")
    sql = "BEGIN;" & vbCrLf & "DELETE FROM rlarp.price_map;" & vbCrLf & "INSERT INTO rlarp.price_map" & vbCrLf & sql & ";" & vbCrLf & "COMMIT;"
    
    If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "10.56.60.254", False, "ptrowbridge", "qqqx53!030", "Port=5432;Database=ubm") Then
@ -1671,7 +1671,7 @@ Sub pricegroup_upload()
    
    Call x.ADOp_CloseCon(0)
    
-    sql = x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, True, "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "A", "A", "A")
+    sql = x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, True, "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "A", "A", "J")
    sql = "BEGIN" & vbCrLf & "DELETE FROM rlarp.price_map;" & vbCrLf & "INSERT INTO rlarp.price_map" & vbCrLf & sql & ";" & vbCrLf & "END"
    
    If Not x.ADOp_Exec(0, sql, 1, True, ADOinterface.SqlServer, "usmidsql01", True) Then
@ -1684,7 +1684,7 @@ Sub pricegroup_upload()
    
    Set x = Nothing
    
-    Call pricegroup_upload_db2
+    'Call pricegroup_upload_db2
    
    MsgBox ("Upload Complete")

--- a/PriceLists.bas
+++ b/PriceLists.bas
@ -545,6 +545,98 @@ Sub build_price_level(plev As String)
    effdate = CDate(pricelevel.tbEddDate.text)
    filepath = pricelevel.tbPATH & "\" & plev
    
+    '---------------------create new workbook-------------------------------------------------------------------
+    Set nwb = Application.Workbooks.Add
+    nwb.Activate
+    Set nws = nwb.Sheets(1)
+    segment_regex = "^G|^N|^F|^P"
+    
+    '---------------------get price list------------------------------------------------------------------------
+    If pricelevel.chbNURSERY Then
+        pln = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "', '^N')", False, 2000, True, PostgreSQLODBC, "usmidsap01", False, login.tbU.text, login.tbP.text, "Port=5432;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|^P"
+            Set nnws = nwb.Sheets.Add(, nws)
+            nnws.Name = "Price List - Nursery"
+            Call paste_pretty(pln, nnws, effdate, curr)
+        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, "usmidsap01", False, login.tbU.text, login.tbP.text, "Port=5432;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|^P" Then
+                segment_regex = "^G|^P"
+            Else
+                segment_regex = "^G|^N|^P"
+            End If
+            Set nfws = nwb.Sheets.Add(, nws)
+            nfws.Name = "Price List - Fiber"
+            Call paste_pretty(plf, nfws, effdate, curr)
+        End If
+    End If
+    
+    pl = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','" & segment_regex & "')", False, 2000, True, PostgreSQLODBC, "usmidsap01", False, login.tbU.text, login.tbP.text, "Port=5432;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, curr)
+    Else
+        '---if the price list has no length, then close
+        nwb.Close
+        Exit Sub
+    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
+    
+    fname = "HC Companies Distributor Price List " & curr & ".xlsx"
+    
+    Dim wb As Workbook
+    For Each wb In Workbooks
+        If wb.Name = fname Then
+            If MsgBox("already have a price list open, close it?", vbOKCancel) Then
+                Workbooks(fname).Close
+                Exit For
+            Else
+                Exit Sub
+            End If
+        End If
+    Next wb
+    
+    If pricelevel.tbPATH.text <> "" Then nwb.SaveAs Filename:=filepath & "\" & fname
+    
+    If pricelevel.chPDF Then
+        fname = Replace(fname, "xlsx", "pdf")
+        nwb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=filepath & "\" & fname, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
+    End If
+    
+    If Not pricelevel.chbLEAVEOPEN Then
+        nwb.Close
+    End If
+    
+    '--------------------get full code list-----------------------------
    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, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
@ -610,99 +702,25 @@ Sub build_price_level(plev As String)
        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
-
-    'Application.ScreenUpdating = True
-    'Exit Sub
-    
-    '---------------------create new workbook-------------------------------------------------------------------
-    Set nwb = Application.Workbooks.Add
-    nwb.Activate
-    Set nws = nwb.Sheets(1)
-    segment_regex = "^G|^N|^F|^P"
-    
-    '---------------------get price list------------------------------------------------------------------------
-    If pricelevel.chbNURSERY Then
-        pln = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "', '^N')", False, 2000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;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|^P"
-            Set nnws = nwb.Sheets.Add(, nws)
-            nnws.Name = "Price List - Nursery"
-            Call paste_pretty(pln, nnws, effdate, curr)
-        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, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;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|^P" Then
-                segment_regex = "^G|^P"
-            Else
-                segment_regex = "^G|^N|^P"
-            End If
-            Set nfws = nwb.Sheets.Add(, nws)
-            nfws.Name = "Price List - Fiber"
-            Call paste_pretty(plf, nfws, effdate, curr)
-        End If
-    End If
-    
-    pl = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','" & segment_regex & "')", False, 2000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;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, curr)
-    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
+        '------------formatting for print-----------------------------------
+        Application.PrintCommunication = False
+        fcws.PageSetup.PrintTitleRows = "$1:$3"
+        fcws.PageSetup.Orientation = xlLandscape
+        With ActiveSheet.PageSetup
+            .LeftMargin = Application.InchesToPoints(0.25)
+            .RightMargin = Application.InchesToPoints(0.25)
+            .TopMargin = Application.InchesToPoints(0.75)
+            .BottomMargin = Application.InchesToPoints(0.75)
+            .HeaderMargin = Application.InchesToPoints(0.3)
+            .FooterMargin = Application.InchesToPoints(0.3)
+            .FitToPagesWide = 1
+            .FitToPagesTall = False
        End With
-    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 = fname Then
-            If MsgBox("already have a price list open, close it?", vbOKCancel) Then
-                Workbooks(fname).Close
-                Exit For
-            Else
-                Exit Sub
-            End If
-        End If
-    Next wb
-    
-    If pricelevel.tbPATH.text <> "" Then nwb.SaveAs Filename:=filepath & "\" & fname
-    
-    If pricelevel.chPDF Then
-        fname = Replace(fname, "xlsx", "pdf")
-        nwb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=filepath & "\" & fname, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
+        Application.PrintCommunication = True
    End If

-    If Not pricelevel.chbLEAVEOPEN Then
-        nwb.Close
-    End If
+    
+    '---------------------save full code list---------------------------

    For Each wb In Workbooks
        If wb.Name = "HC FullCode List.xlsx" Then
@ -716,7 +734,11 @@ Sub build_price_level(plev As String)
    Next wb
    
    If Not (fcwb Is Nothing) Then
-        If pricelevel.tbPATH.text <> "" Then fcwb.SaveAs Filename:=filepath & "\HC FullCode List.xlsx"
+        If pricelevel.tbPATH.text <> "" Then fcwb.SaveAs Filename:=filepath & "\HC FullCode List " & curr & ".xlsx"
+        If pricelevel.chPDF Then
+            fname = Replace(fcwb.Name, "xlsx", "pdf")
+            fcwb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=filepath & "\" & fname, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
+        End If
        If Not pricelevel.chbLEAVEOPEN Then
            fcwb.Close
        End If
--- a/Windows_API.cls
+++ b/Windows_API.cls
@ -1,3 +1,12 @@
+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
@ -164,7 +173,7 @@ End Function
 Sub TrackKeyPressInit()

    Dim msgMessage As MSG
-    Dim bCancel As Boolean
+    Dim bCANCEL As Boolean
    Dim iKeyCode As Integer
    Dim lXLhwnd As Long

@ -191,12 +200,12 @@ Sub TrackKeyPressInit()
            If iKeyCode = vbKeyBack Then SendKeys "{BS}"
            If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}"
           'assume the cancel argument is False.
-            bCancel = 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
+            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
+            If bCANCEL = False Then
                PostMessage _
                lXLhwnd, msgMessage.Message, msgMessage.wParam, 0
            End If
@ -219,18 +228,20 @@ 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)
+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 Not Intersect(Target, Range("A1:D10")) Is Nothing Then
        If Chr(KeyAscii) Like "[0-9]" Then
-            MsgBox MSG & range("A1:D10").Address(False, False) _
+            MsgBox MSG & Range("A1:D10").address(False, False) _
            & """ .", vbCritical, TITLE
-            Cancel = True
+            cancel = True
        End If
    End If

 End Sub

+
+
--- a/pricelevel.frm
+++ b/pricelevel.frm
@ -14,6 +14,7 @@ Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False

+
 Option Explicit

 Public x As New TheBigOne
@ -61,6 +62,8 @@ Private Sub lbPriceLev_Click()

 End Sub

+
+
 Private Sub UserForm_Initialize()

    Me.cancel = True
@ -89,7 +92,7 @@ Sub repopulate()
        End If
    Next i
    
-    tbEddDate.text = "03/01/2023"
+    tbEddDate.text = Format(Date, "mm/dd/yyyy")


 End Sub
--- a/pricelevel.frx
+++ b/pricelevel.frx
--- a/pricelist.frm
+++ b/pricelist.frm
@ -14,6 +14,7 @@ Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False

+
 Option Explicit

 Public proceed As Boolean
--- a/pricelist.frx
+++ b/pricelist.frx
Author	SHA1	Message	Date
Paul Trowbridge	0f7b5db8b8	include currency in name of full code file	2023-05-22 12:07:26 -04:00
Paul Trowbridge	015f2679f9	convert fullcode to pdf	2023-05-22 11:41:09 -04:00