include currency in name of full code file

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")
 

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
+        '------------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.PrintCommunication = True
     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
-    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
+    '---------------------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

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
 
+
+

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

pricelist.frm

@@ -14,6 +14,7 @@ Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
+
 Option Explicit
 
 Public proceed As Boolean