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

live check of price list against lgdat records to test if inbound charges are new or update

Browse Source
This commit is contained in:
Paul Trowbridge 2020-06-25 16:58:13 -04:00
parent c14ba755f8
commit d10a15f113
4 changed files with 108 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
FL.bas
View File

@ -1247,6 +1247,8 @@ Sub build_price_upload()
Dim pl_d2 As String
Dim pl_d3 As String
Dim fd As FileDialog
Dim ulsql As String
Dim temp() As String
pl = x.SHTp_GetString(Selection)
ReDim ul(11, UBound(pl, 2))
@ -1255,14 +1257,17 @@ PRICELIST_SHOW:
pricelist.Show
pl_code = pricelist.tbCODE.Text
If Not pricelist.proceed Then Exit Sub
pl_code = pricelist.cbLIST.value
pl_d1 = pricelist.tbD1.Text
pl_d2 = pricelist.tbD2.Text
pl_d3 = pricelist.tbD3.Text
pl_action = Mid(pricelist.cbHDR.value, 1, 1)
dtl_action = Mid(pricelist.cbDTL.value, 1, 1)
If Len(pricelist.tbCODE) > 5 Then
If Len(pricelist.cbLIST.value) > 5 Then
MsgBox ("price code must be 5 or less characters")
GoTo PRICELIST_SHOW
End If
@ -1275,6 +1280,32 @@ PRICELIST_SHOW:
Call x.TBLp_FilterSingle(pl, 10, "A", True)
End If
'need to get the current list of products and if they already exist for the target price list
'target price list
'target part
'target volume level
ulsql = FL.x.SQLp_build_sql_values(pl, True, True, Db2, False)
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
If Not FL.x.ADOp_Exec(0, ulsql, 1, True, ISeries, "S7830956", False, login.tbU.Text, login.tbP.Text) 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(1, 0) = pl_action
@ -1287,15 +1318,15 @@ PRICELIST_SHOW:
j = 0
For i = LBound(pl, 2) + 1 To UBound(pl, 2)
'if there is no [uom, part#, price], don't create a row
If pl(12, i) <> "" And pl(13, i) <> "" And pl(8, i) <> "" And pl(9, i) <> "" Then
If pl(11, i) <> "" And pl(12, i) <> "" And pl(7, i) <> "" And pl(8, i) <> "" Then
j = j + 1
ul(0, j) = "DTL" 'DTL
ul(1, j) = pl_code 'Price list code
ul(2, j) = pl(9, i) 'part number
ul(3, j) = pl(7, i) 'price unit
ul(4, j) = Format(CDbl(pl(6, i)) * CDbl(pl(12, i)) / CDbl(pl(13, i)), "0.00") 'volume break in price uom
ul(5, j) = Format(pl(8, i), "0.00") 'price
ul(11, j) = dtl_action 'add, update, delete
ul(2, j) = pl(8, i) 'part number
ul(3, j) = pl(6, i) 'price unit
ul(4, j) = Format(CDbl(pl(5, i)) * CDbl(pl(11, i)) / CDbl(pl(12, i)), "0.00") 'volume break in price uom
ul(5, j) = Format(pl(7, i), "0.00") 'price
ul(11, j) = pl(17, i) 'add, update, delete
End If
Next i
@ -1304,11 +1335,11 @@ PRICELIST_SHOW:
'--------Open file-------------
If Not x.FILEp_CreateCSV(pricelist.tbPATH.Text & "\" & pl_code & ".csv", ul) Then
If Not x.FILEp_CreateCSV(pricelist.tbPATH.Text & "\" & Replace(pl_code, ".", "_") & ".csv", ul) Then
MsgBox ("error")
End If
Excel.Workbooks.Open (pricelist.tbPATH.Text & "\" & pl_code & ".csv")
Excel.Workbooks.Open (pricelist.tbPATH.Text & "\" & Replace(pl_code, ".", "_") & ".csv")
'---------------------header row---------------------------------

BIN
login.frx
View File

Binary file not shown.

68
pricelist.frm
View File

@ -1,10 +1,10 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} pricelist
Caption = "Price List Name"
ClientHeight = 6240
ClientHeight = 7680
ClientLeft = 120
ClientTop = 465
ClientWidth = 4095
ClientWidth = 8895.001
OleObjectBlob = "pricelist.frx":0000
StartUpPosition = 1 'CenterOwner
End
@ -14,6 +14,10 @@ Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public proceed As Boolean
Private pl() As String
Private plv() As Variant
Private plfv() As Variant
Private Sub bCANCEL_Click()
proceed = False
@ -21,6 +25,12 @@ Private Sub bCANCEL_Click()
End Sub
Private Sub bOK_Click()
If tbPATH = "" Then
MsgBox ("no directory specified")
Exit Sub
End If
proceed = True
Me.Hide
End Sub
@ -38,12 +48,40 @@ Private Sub bPICK_Click()
End Sub
Private Sub cbLIST_Change()
Dim plc() As String
plc = pl
Call FL.x.TBLp_FilterSingle(plc, 0, cbLIST.value, True)
If UBound(plc, 2) = 0 Then Exit Sub
Me.tbD1 = plc(5, 1)
'Me.tbD2 = plc(12, 1)
'Me.tbD3 = plc(13, 1)
End Sub
Private Sub lbLIST_Click()
Dim i As Long
For i = 1 To lbLIST.ListCount
If lbLIST.Selected(i) Then
cbLIST.value = lbLIST.list(i, 0)
Exit Sub
End If
Next i
Me.cbHDR.value = "3 - Update"
End Sub
Private Sub UserForm_Initialize()
proceed = False
Dim x() As Variant
Dim i As Long
ReDim x(3)
x(1) = "1 - New"
x(2) = "2 - Replace"
x(3) = "3 - Update"
@ -58,6 +96,32 @@ Private Sub UserForm_Initialize()
cbHDR.list = x
cbDTL.list = dtl
If login.tbP = "" Then
login.Show
If Not login.proceed Then Exit Sub
If Not FL.x.ADOp_OpenCon(0, ISeries, "S7830956", False, login.tbU, login.tbP) Then
MsgBox (FL.x.ADOo_errstring)
Exit Sub
End If
End If
pl = FL.x.ADOp_SelectS(0, "SELECT plcode, func, basis, tier, currency, d1 FROM RLARP.PLM p ORDER BY func, tier", True, 1000, True)
Call FL.x.ADOp_CloseCon(0)
ReDim plv(1 To UBound(pl, 2))
For i = 1 To UBound(pl, 2)
plv(i) = pl(0, i)
Next i
plfv = FL.x.TBLp_StringToVar(FL.x.TBLp_Transpose(pl))
cbLIST.list = plv
lbLIST.list = plfv
'lbHEAD.ColumnCount = lbHist.ColumnCount
'lbHEAD.ColumnWidths = lbHist.ColumnWidths
Call FL.x.frmListBoxHeader(lbHEAD, lbLIST, "plcode", "func", "basis", "tier", "currency", "d1")
End Sub

BIN
pricelist.frx
View File

Binary file not shown.