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

clean up and move code to core list file

This commit is contained in:
Paul Trowbridge 2022-05-20 12:38:56 -04:00
parent a788a91424
commit 69af558e8b
7 changed files with 46 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
PriceLists.bas
View File

@ -34,6 +34,9 @@ Sub test_full20()
unp = unpivot_current_sheet(lists, pcol) unp = unpivot_current_sheet(lists, pcol)
login.Caption = "Postgres Login"
login.tbU = "report"
login.tbP = "report"
login.Show login.Show
If Not login.proceed Then Exit Sub If Not login.proceed Then Exit Sub
@ -240,6 +243,11 @@ Sub price_load_plcore()
sql = sql & vbCrLf & "INSERT INTO rlarp.plcore" sql = sql & vbCrLf & "INSERT INTO rlarp.plcore"
sql = sql & vbCrLf & x.SQLp_build_sql_values(load, True, True, PostgreSQL, False, False, "S", "S", "S", "S", "S", "S", "S", "N", "N", "S", "N", "N") & ";" sql = sql & vbCrLf & x.SQLp_build_sql_values(load, True, True, PostgreSQL, False, False, "S", "S", "S", "S", "S", "S", "S", "N", "N", "S", "N", "N") & ";"
login.Caption = "Postgres Login"
login.tbU = LCase(Mid(Application.UserLibraryPath, 10, InStr(10, Application.UserLibraryPath, "\") - 10))
login.Show
If Not login.proceed Then Exit Sub
If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU, login.tbP, "Port=5030;Database=ubm") Then If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU, login.tbP, "Port=5030;Database=ubm") Then
MsgBox (x.ADOo_errstring) MsgBox (x.ADOo_errstring)
Exit Sub Exit Sub
@ -318,33 +326,6 @@ PRICELIST_SHOW:
'target volume level 'target volume level
'ulsql = FL.x.SQLp_build_sql_values(pl, True, True, PostgreSQL, False)
'pl = x.TBLp_Transpose(pl)
'plv = x.TBLp_StringToVar(pl)
'ulsql = x.json_from_table(plv, "")
'ulsql = "DECLARE GLOBAL TEMPORARY TABLE session.plb AS (" & ulsql & ") WITH DATA"
' If login.tbP.Text = "" Then
' login.Show
' If Not login.proceed Then
' Exit Sub
' End If
' End If
'Call wapi.ClipBoard_SetData(ulsql)
'Exit Sub
'If Not FL.x.ADOp_Exec(0, ulsql, 1, True, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@041") Then
' MsgBox (FL.x.ADOo_errstring)
' Exit Sub
'End If
'pl = FL.x.ADOp_SelectS(0, "SELECT p.*, CASE WHEN COALESCE(c.jcpart,'') = '' THEN '1' ELSE '2' END flag FROM Session.plb P LEFT OUTER JOIN lgdat.iprcc c ON c.jcpart = P.Item AND c.JCPLCD = '" & pl_code & "' AND c.JCVOLL = p.vbqty * cast(p.num as float) / cast(p.den as float)", True, 10000, True)
'If Not FL.x.ADOp_Exec(0, "DROP TABLE SESSION.PLB", 1, True, ISeries, "S7830956", False, login.tbU.Text, login.tbP.Text) Then
' MsgBox (FL.x.ADOo_errstring)
' Exit Sub
'End If
'Call FL.x.ADOp_CloseCon(0)
ul(0, 0) = "HDR" ul(0, 0) = "HDR"
ul(1, 0) = pl_action ul(1, 0) = pl_action
ul(2, 0) = pl_code ul(2, 0) = pl_code
@ -758,7 +739,7 @@ Sub build_customer_files()
End If End If
Next wb Next wb
nwb.SaveAs Filename:=filepath & "\HC Companies Distributor Price List.xlsx" If filepath <> "" Then nwb.SaveAs Filename:=filepath & "\HC Companies Distributor Price List.xlsx"
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
@ -771,7 +752,7 @@ Sub build_customer_files()
End If End If
Next wb Next wb
fcwb.SaveAs Filename:=filepath & "\HC FullCode List.xlsx" If filepath <> "" Then fcwb.SaveAs Filename:=filepath & "\HC FullCode List.xlsx"
End Sub End Sub
@ -968,10 +949,3 @@ Sub print_setup(sheet As Worksheet, last_row As Long)
Application.PrintCommunication = True Application.PrintCommunication = True
End Sub End Sub
Sub call_print()
Call print_setup(ActiveSheet, 1201)
End Sub

8
login.frm
View File

@ -13,13 +13,15 @@ Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False Attribute VB_Exposed = False
Public proceed As Boolean Public proceed As Boolean
Private Sub cbCANCEL_Click() Private Sub cbCancel_Click()
tbU.Text = "" tbU.text = ""
tbP.Text = "" tbP.text = ""
proceed = False proceed = False
Me.Hide Me.Hide
End Sub End Sub

BIN
login.frx
View File

Binary file not shown.

7
pricelevel.frm
View File

@ -13,6 +13,7 @@ Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False Attribute VB_Exposed = False
Option Explicit Option Explicit
Public x As New TheBigOne Public x As New TheBigOne
@ -33,7 +34,7 @@ Private Sub cbFolder_Click()
Set fd = Application.FileDialog(msoFileDialogFolderPicker) Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Show fd.Show
tbPath.text = fd.SelectedItems(1) tbPATH.text = fd.SelectedItems(1)
End Sub End Sub
@ -66,12 +67,12 @@ End Sub
Sub repopulate() Sub repopulate()
Dim pl() As String Dim pl() As String
pl = x.SHTp_Get("Price Levels", 2, 1, True) pl = x.SHTp_Get("Price Levels", 3, 1, True)
Me.lbPriceLev.list = x.TBLp_StringToVar(x.TBLp_Transpose(pl)) Me.lbPriceLev.list = x.TBLp_StringToVar(x.TBLp_Transpose(pl))
Dim i As Long Dim i As Long
For i = 1 To lbPriceLev.ListCount For i = 1 To lbPriceLev.ListCount - 1
If lbPriceLev.list(i, 0) = Selection Then If lbPriceLev.list(i, 0) = Selection Then
lbPriceLev.Selected(i) = True lbPriceLev.Selected(i) = True
Me.tbPriceLev = Selection Me.tbPriceLev = Selection

BIN
pricelevel.frx
View File

Binary file not shown.

57
pricelist.frm
View File

@ -13,12 +13,15 @@ Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False Attribute VB_Exposed = False
Option Explicit Option Explicit
Public proceed As Boolean Public proceed As Boolean
Private pl() As String Private pl() As String
Private plv() As Variant Private plv() As Variant
Private plfv() As Variant Private plfv() As Variant
Public tbo As New TheBigOne
Private Sub bCANCEL_Click() Private Sub bCANCEL_Click()
@ -60,7 +63,7 @@ Private Sub cbLIST_Change()
Dim plc() As String Dim plc() As String
plc = pl plc = pl
Call FL.x.TBLp_FilterSingle(plc, 0, cbLIST.value, True) Call tbo.TBLp_FilterSingle(plc, 0, cbLIST.value, True)
If UBound(plc, 2) = 0 Then Exit Sub If UBound(plc, 2) = 0 Then Exit Sub
Me.tbD1 = plc(1, 1) Me.tbD1 = plc(1, 1)
Me.tbD2 = plc(2, 1) Me.tbD2 = plc(2, 1)
@ -85,7 +88,6 @@ End Sub
Private Sub UserForm_Initialize() Private Sub UserForm_Initialize()
proceed = False proceed = False
Dim x() As Variant Dim x() As Variant
Dim i As Long Dim i As Long
@ -105,29 +107,26 @@ Private Sub UserForm_Initialize()
cbHDR.list = x cbHDR.list = x
cbDTL.list = dtl cbDTL.list = dtl
' If login.tbP = "" Then login.Caption = "CMS Login"
' login.Show login.tbU = Mid(Application.UserName, 1, 10)
' If Not login.proceed Then Exit Sub login.tbP = ""
' If Not FL.x.ADOp_OpenCon(0, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@041") Then login.Show
' MsgBox (FL.x.ADOo_errstring) If Not login.proceed Then Exit Sub
' Exit Sub
' End If
' End If
If Not FL.x.ADOp_OpenCon(1, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@048") Then If Not tbo.ADOp_OpenCon(1, ISeries, "S7830956", False, login.tbU.text, login.tbP.text) Then
MsgBox (FL.x.ADOo_errstring) MsgBox (tbo.ADOo_errstring)
Exit Sub Exit Sub
End If End If
pl = FL.x.ADOp_SelectS(1, "SELECT JAPLCD, JAPLDS, JAPLD1, JAPLD2 FROM lgdat.iprca WHERE TRIM(COALESCE(JAPLCD,'')) <> '' ORDER BY JAPLCD ASC", True, 1000, False) pl = tbo.ADOp_SelectS(1, "SELECT JAPLCD, JAPLDS, JAPLD1, JAPLD2 FROM lgdat.iprca WHERE TRIM(COALESCE(JAPLCD,'')) <> '' ORDER BY JAPLCD ASC", True, 1000, False)
'pl = FL.x.ADOp_SelectS(1, "SELECT plcode, d1,d2,d3 FROM RLARP.PLM p ORDER BY plcode", True, 1000, True) 'pl = FL.x.ADOp_SelectS(1, "SELECT plcode, d1,d2,d3 FROM RLARP.PLM p ORDER BY plcode", True, 1000, True)
Call FL.x.ADOp_CloseCon(1) Call tbo.ADOp_CloseCon(1)
ReDim plv(1 To UBound(pl, 2)) ReDim plv(1 To UBound(pl, 2))
For i = 1 To UBound(pl, 2) For i = 1 To UBound(pl, 2)
plv(i) = pl(0, i) plv(i) = pl(0, i)
Next i Next i
plfv = FL.x.TBLp_StringToVar(FL.x.TBLp_Transpose(pl)) plfv = tbo.TBLp_StringToVar(tbo.TBLp_Transpose(pl))
@ -137,7 +136,7 @@ Private Sub UserForm_Initialize()
'lbHEAD.ColumnCount = lbHist.ColumnCount 'lbHEAD.ColumnCount = lbHist.ColumnCount
'lbHEAD.ColumnWidths = lbHist.ColumnWidths 'lbHEAD.ColumnWidths = lbHist.ColumnWidths
Call FL.x.frmListBoxHeader(lbHEAD, lbLIST, "plcode", "descr1", "descr2", "descr3") Call tbo.frmListBoxHeader(lbHEAD, lbLIST, "plcode", "descr1", "descr2", "descr3")
@ -167,29 +166,27 @@ Sub load_lists()
cbHDR.list = x cbHDR.list = x
cbDTL.list = dtl cbDTL.list = dtl
' If login.tbP = "" Then login.Caption = "CMS Login"
' login.Show login.tbU = Mid(UCase(Mid(Application.UserLibraryPath, 10, InStr(10, Application.UserLibraryPath, "\") - 10)), 1, 10)
' If Not login.proceed Then Exit Sub login.tbP = ""
' If Not FL.x.ADOp_OpenCon(0, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@041") Then login.Show
' MsgBox (FL.x.ADOo_errstring) If Not login.proceed Then Exit Sub
' Exit Sub
' End If
' End If
If Not FL.x.ADOp_OpenCon(1, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@048") Then
MsgBox (FL.x.ADOo_errstring) If Not tbo.ADOp_OpenCon(1, ISeries, "S7830956", False, login.tbU.text, login.tbP.text) Then
MsgBox (tbo.ADOo_errstring)
Exit Sub Exit Sub
End If End If
'pl = FL.x.ADOp_SelectS(1, "SELECT plcode, d1, d2, d3 FROM RLARP.PLM p ORDER BY plcode", True, 1000, True) 'pl = FL.x.ADOp_SelectS(1, "SELECT plcode, d1, d2, d3 FROM RLARP.PLM p ORDER BY plcode", True, 1000, True)
pl = FL.x.ADOp_SelectS(1, "SELECT JAPLCD, JAPLDS, JAPLD1, JAPLD2 FROM lgdat.iprca WHERE TRIM(COALESCE(JAPLCD,'')) <> '' ORDER BY JAPLCD ASC", True, 1000, False) pl = tbo.ADOp_SelectS(1, "SELECT JAPLCD, JAPLDS, JAPLD1, JAPLD2 FROM lgdat.iprca WHERE TRIM(COALESCE(JAPLCD,'')) <> '' ORDER BY JAPLCD ASC", True, 1000, False)
Call FL.x.ADOp_CloseCon(1) Call tbo.ADOp_CloseCon(1)
ReDim plv(1 To UBound(pl, 2)) ReDim plv(1 To UBound(pl, 2))
For i = 1 To UBound(pl, 2) For i = 1 To UBound(pl, 2)
plv(i) = pl(0, i) plv(i) = pl(0, i)
Next i Next i
plfv = FL.x.TBLp_StringToVar(FL.x.TBLp_Transpose(pl)) plfv = tbo.TBLp_StringToVar(tbo.TBLp_Transpose(pl))
cbLIST.list = plv cbLIST.list = plv
lbLIST.list = plfv lbLIST.list = plfv
@ -197,6 +194,6 @@ Sub load_lists()
'lbHEAD.ColumnCount = lbHist.ColumnCount 'lbHEAD.ColumnCount = lbHist.ColumnCount
'lbHEAD.ColumnWidths = lbHist.ColumnWidths 'lbHEAD.ColumnWidths = lbHist.ColumnWidths
Call FL.x.frmListBoxHeader(lbHEAD, lbLIST, "plcode", "d1", "d2", "d3") Call tbo.frmListBoxHeader(lbHEAD, lbLIST, "plcode", "d1", "d2", "d3")
End Sub End Sub

BIN
pricelist.frx
View File

Binary file not shown.