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

Compare commits

base: pt:a55b719e9495c24c66efdf4e9fc078efacdbcd17
Branches Tags
pt:master
..
compare: pt:48670f9ca7d00ae947a2625cdb962e4795b98e84
Branches Tags
pt:master

No commits in common. "a55b719e9495c24c66efdf4e9fc078efacdbcd17" and "48670f9ca7d00ae947a2625cdb962e4795b98e84" have entirely different histories.
a55b719e94 ... 48670f9ca7

2 changed files with 22 additions and 30 deletions
Show Stats Expand all files Collapse all files

22
FL.bas
View File

@ -541,7 +541,7 @@ Sub sql_from_range_db2_noqh()
Dim wapi As New Windows_API Dim wapi As New Windows_API
Dim r() As String Dim r() As String
Selection.CurrentRegion.Select Selection.CurrentRegion.Select
Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, Db2, False, True)) Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, Db2, False))
End Sub End Sub
@ -561,13 +561,13 @@ Sub sql_from_range_pg_noqh()
Dim wapi As New Windows_API Dim wapi As New Windows_API
Dim r() As String Dim r() As String
Selection.CurrentRegion.Select Selection.CurrentRegion.Select
Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, False)) Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False))
End Sub End Sub
Sub auto_fit_range() Sub auto_fit_range()
Selection.CurrentRegion.Columns.autofit Selection.CurrentRegion.Columns.AutoFit
End Sub End Sub
@ -824,7 +824,7 @@ Sub extract_price_matrix()
Call x.SHTp_Dump(cms_pl, new_sh.Name, 1, 1, True, True) Call x.SHTp_Dump(cms_pl, new_sh.Name, 1, 1, True, True)
new_sh.Select new_sh.Select
ActiveSheet.Cells(1, 1).CurrentRegion.Select ActiveSheet.Cells(1, 1).CurrentRegion.Select
Selection.Columns.autofit Selection.Columns.AutoFit
Rows("1:1").Select Rows("1:1").Select
With ActiveWindow With ActiveWindow
@ -1045,7 +1045,7 @@ Sub extract_price_matrix_suff()
Call x.SHTp_Dump(cms_pl, new_sh.Name, 1, 1, True, True) Call x.SHTp_Dump(cms_pl, new_sh.Name, 1, 1, True, True)
new_sh.Select new_sh.Select
ActiveSheet.Cells(1, 1).CurrentRegion.Select ActiveSheet.Cells(1, 1).CurrentRegion.Select
Selection.Columns.autofit Selection.Columns.AutoFit
Rows("1:1").Select Rows("1:1").Select
With ActiveWindow With ActiveWindow
@ -1294,7 +1294,7 @@ PRICELIST_SHOW:
'--------Open file------------- '--------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") MsgBox ("error")
End If End If
@ -1412,12 +1412,12 @@ Sub price_issues()
If ActiveSheet.Name <> "Issues" Then Exit Sub If ActiveSheet.Name <> "Issues" Then Exit Sub
ilist = x.SHTp_Get(ActiveSheet.Name, 1, 1, True) ilist = x.SHTp_Get(ActiveSheet.Name, 1, 1, True)
sql = "MERGE INTO RLARP.ISSUES i USING (" & vbCrLf sql = "BEGIN;" & vbCrLf & "DELETE FROM rlarp.issues;" & vbCrLf & "INSERT INTO rlarp.issues" & vbCrLf
sql = sql & x.SQLp_build_sql_values(ilist, True, True, Db2, False, True, "N", "N", "S", "D") sql = sql & x.SQLp_build_sql_values(ilist, True, True, PostgreSQL, False, "S", "S", "S", "S") & ";"
sql = sql & vbCrLf & ") x ON" & vbCrLf & " x.ordern = i.ordern" & vbCrLf & " AND x.linen = i.linen" & vbCrLf & "WHEN MATCHED THEN UPDATE SET" & vbCrLf & " i.issue = x.issue" & vbCrLf & " ,i.odate = x.odate" & vbCrLf & "WHEN NOT MATCHED THEN INSERT VALUES (" & vbCrLf & " x.ordern , x.linen, x.issue, x.odate" & vbCrLf & ")" sql = sql & vbCrLf & "END;"
If Not x.ADOp_Exec(0, sql, 1, True, ISeries, "s7830956", False, "ptrowbridg", "qqqx53@048") Then If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then
MsgBox (x.ADOo_errstring) MsgBox (x.ADOo_errstring)
End If End If
@ -1659,5 +1659,3 @@ Sub clear_page_breaks()
Next b Next b
End Sub End Sub

30
PriceLists.bas
View File

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