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

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

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

Binary file not shown.

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"
@ -53,11 +91,37 @@ Private Sub UserForm_Initialize()
dtl(1) = "1 - Add"
dtl(2) = "2 - Update"
dtl(3) = "3 - Delete"
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

Binary file not shown.