diff --git a/FL.bas b/FL.bas index 9b10089..0243ce5 100644 --- a/FL.bas +++ b/FL.bas @@ -820,392 +820,6 @@ Sub extract_price_matrix() '------------------------------------setup------------------------------------------------- - Dim wapi As New Windows_API - Dim x As New TheBigOne - Dim tbl() As Variant - Dim unp() As String - Dim unps() As String - Dim sql As String - Dim error As String - Dim orig As Range - Dim cms_pl() As String - Dim pw As String - Dim new_sh As Worksheet - Dim ws As Worksheet - Dim cp As CustomProperty - - '------------------------------------selection------------------------------------------------- - - Set orig = Application.Selection - - Selection.CurrentRegion.Select - - Set orig = Application.Selection - - '--------------------------------test if valid price matrix------------------------------ - - If Selection.Cells.Count = 1 Then - MsgBox ("selection is not a table") - orig.Select - Exit Sub - End If - - tbl = Selection - - If UBound(tbl, 1) < 4 Then error = "selection is not a valid price matrix" - If UBound(tbl, 2) < 2 Then error = "selection is not a valid price matrix" - - If Not error = "" Then - MsgBox (error) - Exit Sub - End If - - '-----------------------------unpivot price matrix into new array----------------------------- - - Dim i As Long - Dim j As Long - Dim k As Long - k = 0 - ReDim unp(8, (UBound(tbl, 2) - 1) * (UBound(tbl, 1) - 4)) - For i = 5 To UBound(tbl, 1) - For j = 2 To UBound(tbl, 2) - k = k + 1 - 'part - unp(0, k) = tbl(i, 1) - 'copy headers down the left - unp(1, k) = tbl(1, j) 'color code/tier (row one, column j) - unp(2, k) = tbl(2, j) 'size code (row two, column j) - unp(3, k) = tbl(3, j) 'volue break uom (row 3, column j) - unp(4, k) = Format(tbl(4, j), "#.00") 'volue break qty (row 4, column j) - unp(5, k) = "M" 'pricing unit of measuer - unp(6, k) = Format(tbl(i, j), "#.00") 'price (row i, column j) - unp(7, k) = i - unp(8, k) = j - Next j - Next i - unp(0, 0) = "mold" - unp(1, 0) = "sizc" - unp(2, 0) = "color" - unp(3, 0) = "vbuom" - unp(4, 0) = "vbqty" - unp(5, 0) = "puom" - unp(6, 0) = "price" - unp(7, 0) = "orig_row" - unp(8, 0) = "orig_col" - - If Not x.TBLp_TestNumeric(unp, 4) Then - MsgBox ("volume break quantity is text") - Exit Sub - End If - - If Not x.TBLp_TestNumeric(unp, 6) Then - MsgBox ("price is text") - Exit Sub - End If - - '-------------------------prepare sql to upload--------------------------------------------------------------- - - sql = x.SQLp_build_sql_values(unp, False, True, Db2, False) - sql = "DECLARE GLOBAL TEMPORARY TABLE session.plbuild AS (" & sql & ") WITH DATA" - Call wapi.ClipBoard_SetData(sql) - - If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub - - login.Show - If Not login.proceed Then Exit Sub - - - If Not x.ADOp_OpenCon(0, ISeries, "S7830956", False, login.tbU.Text, login.tbP.Text) Then - MsgBox ("not able to connect to CMS" & vbCrLf & x.ADOo_errstring) - Exit Sub - End If - - If Not x.ADOp_Exec(0, sql) Then - MsgBox (x.ADOo_errstring) - Call x.ADOp_CloseCon(0) - Exit Sub - End If - - '-------------------call price build procedure-------------------------------------------------------- - - cms_pl = x.ADOp_SelectS(0, "CALL rlarp.build_pricelist", True, 25000, True) - - Call x.ADOp_CloseCon(0) - - If x.ADOo_errstring <> "" Then - MsgBox (x.ADOo_errstring) - Exit Sub - End If - - '--------------------------setup an output sheet if necessary------------------------------- - - For Each ws In Application.Worksheets - For Each cp In ws.CustomProperties - If cp.Name = "spec_name" And cp.value = "price_list" Then - Set new_sh = ws - End If - Next cp - Next ws - - If new_sh Is Nothing Then - Set new_sh = Application.Worksheets.Add - Call new_sh.CustomProperties.Add("spec_name", "price_list") - End If - - '-------------------------dump contents------------------------------------------------------ - - Call x.SHTp_Dump(cms_pl, new_sh.Name, 1, 1, True, True) - new_sh.Select - ActiveSheet.Cells(1, 1).CurrentRegion.Select - Selection.Columns.AutoFit - - Rows("1:1").Select - With ActiveWindow - .SplitColumn = 0 - .SplitRow = 1 - End With - ActiveWindow.FreezePanes = True - - - '--------------------------format source cells for any build issues-------------------------------- - - orig.Worksheet.Select - - With orig.Interior - .Pattern = xlNone - .TintAndShade = 0 - .PatternTintAndShade = 0 - End With - - For i = 1 To UBound(cms_pl, 1) - Select Case cms_pl(i, 13) - Case "" - Case "no unit conversion" - orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161) - Case "no part number" - 'orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(220, 220, 220) - End Select - Next i - - '----------------------------cleanup------------------------------------------------------------- - - Set x = Nothing - -End Sub - -Sub extract_price_matrix_r1() - - '------------------------------------setup------------------------------------------------- - - Dim wapi As New Windows_API - Dim x As New TheBigOne - Dim tbl() As Variant - Dim unp() As String - Dim unps() As String - Dim sql As String - Dim error As String - Dim orig As Range - Dim cms_pl() As String - Dim pw As String - Dim new_sh As Worksheet - Dim ws As Worksheet - Dim cp As CustomProperty - - '------------------------------------selection------------------------------------------------- - - Set orig = Application.Selection - - Selection.CurrentRegion.Select - - Set orig = Application.Selection - - '--------------------------------test if valid price matrix------------------------------ - - If Selection.Cells.Count = 1 Then - MsgBox ("selection is not a table") - orig.Select - Exit Sub - End If - - tbl = Selection - - If UBound(tbl, 1) < 4 Then error = "selection is not a valid price matrix" - If UBound(tbl, 2) < 2 Then error = "selection is not a valid price matrix" - - If Not error = "" Then - MsgBox (error) - Exit Sub - End If - - '-----------------------------unpivot price matrix into new array----------------------------- - - Dim i As Long - Dim j As Long - Dim k As Long - k = 0 - ReDim unp(8, (UBound(tbl, 2) - 2) * (UBound(tbl, 1) - 3)) - For i = 4 To UBound(tbl, 1) - For j = 3 To UBound(tbl, 2) - k = k + 1 - 'part - unp(0, k) = tbl(i, 1) - 'copy headers down the left - unp(1, k) = tbl(1, j) 'size code (row two, column j) - unp(2, k) = tbl(i, 2) 'color code/tier (row one, column j) - unp(3, k) = tbl(2, j) 'volue break uom (row 3, column j) - unp(4, k) = Format(tbl(3, j), "#.00") 'volue break qty (row 4, column j) - unp(5, k) = "M" 'pricing unit of measuer - unp(6, k) = Format(tbl(i, j), "#.00") 'price (row i, column j) - unp(7, k) = i - unp(8, k) = j - Next j - Next i - unp(0, 0) = "mold" - unp(1, 0) = "sizc" - unp(2, 0) = "color" - unp(3, 0) = "vbuom" - unp(4, 0) = "vbqty" - unp(5, 0) = "puom" - unp(6, 0) = "price" - unp(7, 0) = "orig_row" - unp(8, 0) = "orig_col" - - If Not x.TBLp_TestNumeric(unp, 4) Then - MsgBox ("volume break quantity is text") - Exit Sub - End If - - If Not x.TBLp_TestNumeric(unp, 6) Then - MsgBox ("price is text") - Exit Sub - End If - - '-------------------------prepare sql to upload--------------------------------------------------------------- - - sql = x.SQLp_build_sql_values(unp, False, True, Db2, False) - sql = "DECLARE GLOBAL TEMPORARY TABLE session.plbuild AS (" & sql & ") WITH DATA" - Call wapi.ClipBoard_SetData(sql) - - If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub - - login.Show - If Not login.proceed Then Exit Sub - - - If Not x.ADOp_OpenCon(0, ISeries, "S7830956", False, login.tbU.Text, login.tbP.Text) Then - MsgBox ("not able to connect to CMS" & vbCrLf & x.ADOo_errstring) - Exit Sub - End If - - If Not x.ADOp_Exec(0, sql) Then - MsgBox (x.ADOo_errstring) - Call x.ADOp_CloseCon(0) - Exit Sub - End If - - '-------------------call price build procedure-------------------------------------------------------- - - cms_pl = x.ADOp_SelectS(0, "CALL rlarp.build_pricelist", True, 25000, True) - - Call x.ADOp_CloseCon(0) - - If x.ADOo_errstring <> "" Then - MsgBox (x.ADOo_errstring) - Exit Sub - End If - - '--------------------------setup an output sheet if necessary------------------------------- - - For Each ws In Application.Worksheets - For Each cp In ws.CustomProperties - If cp.Name = "spec_name" And cp.value = "price_list" Then - Set new_sh = ws - Exit For - End If - Next cp - Next ws - - If new_sh Is Nothing Then - Set new_sh = Application.Worksheets.Add - Call new_sh.CustomProperties.Add("spec_name", "price_list") - End If - - '-------------------------dump contents------------------------------------------------------ - - Call x.SHTp_Dump(cms_pl, new_sh.Name, 1, 1, True, True) - new_sh.Select - ActiveSheet.Cells(1, 1).CurrentRegion.Select - Selection.Columns.AutoFit - - Rows("1:1").Select - With ActiveWindow - .SplitColumn = 0 - .SplitRow = 1 - End With - ActiveWindow.FreezePanes = True - - - '--------------------------format source cells for any build issues-------------------------------- - - orig.Worksheet.Select - - - With orig.Interior - .Pattern = xlNone - .TintAndShade = 0 - .PatternTintAndShade = 0 - End With - - 'if a cell has even one valid hit, don't show an error - 'create a copy of tbl - 'the default value for cell is error, if any good values are found, they stay - - - For i = 1 To UBound(cms_pl, 1) - Select Case cms_pl(i, 13) - Case "" - orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor = xlThemeColorAccent6 - Case "no unit conversion" - If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then - orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161) - End If - Case "no part number" - If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then - orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161) - End If - End Select - Next i - - Dim cell As Range - - For Each cell In Application.Selection.Cells - 'if the cell fill is green, then a known good part was found, so cell to blank - If cell.Interior.ThemeColor = xlThemeColorAccent6 Then - cell.Interior.Pattern = xlNone - Else - If cell.Interior.Pattern = xlNone And cell.value <> "" Then - cell.Interior.Color = RGB(255, 255, 161) - End If - End If - 'if at this point the cell has no background, then there is no part, so highlight it, but only if a price is listed - Next cell - - Selection.Columns(1).Interior.Pattern = xlNone - Selection.Columns(2).Interior.Pattern = xlNone - Selection.Rows(1).Interior.Pattern = xlNone - Selection.Rows(2).Interior.Pattern = xlNone - Selection.Rows(3).Interior.Pattern = xlNone - - '----------------------------cleanup------------------------------------------------------------- - - Set x = Nothing - -End Sub - -Sub extract_price_matrix_r2() - - '------------------------------------setup------------------------------------------------- - Dim wapi As New Windows_API Dim x As New TheBigOne Dim tbl() As Variant @@ -1419,6 +1033,227 @@ Sub extract_price_matrix_r2() ini.Select +End Sub + +Sub extract_price_matrix_suff() + + '------------------------------------setup------------------------------------------------- + + Dim wapi As New Windows_API + Dim x As New TheBigOne + Dim tbl() As Variant + Dim unp() As String + Dim unv() As Variant + Dim unps() As String + Dim sql As String + Dim error As String + Dim orig As Range + Dim ini As Range + Dim cms_pl() As String + Dim pw As String + Dim new_sh As Worksheet + Dim ws As Worksheet + Dim cp As CustomProperty + + '------------------------------------selection------------------------------------------------- + + Set ini = Application.Selection + + Selection.CurrentRegion.Select + + Set orig = Application.Selection + + '--------------------------------test if valid price matrix------------------------------ + + If Selection.Cells.Count = 1 Then + MsgBox ("selection is not a table") + orig.Select + Exit Sub + End If + + tbl = Selection + + If UBound(tbl, 1) < 2 Then error = "selection is not a valid price matrix" + If UBound(tbl, 2) <> 9 Then error = "selection is not a valid price matrix" + + If Not error = "" Then + MsgBox (error) + Exit Sub + End If + + '-----------------------------unpivot price matrix into new array----------------------------- + + Dim i As Long + Dim j As Long + Dim k As Long + Dim m As Long + k = 0 + ReDim unp(9, (UBound(tbl, 1) - 1) * 3) + 'iterate through rows + For i = 2 To UBound(tbl, 1) + '3 iterations per row + For m = 0 To 2 + k = k + 1 + 'part + unp(0, k) = tbl(i, 1) 'stlye code + unp(1, k) = tbl(i, 2) 'color tier + unp(2, k) = tbl(i, 3) 'branding + unp(3, k) = tbl(i, 4) 'kit + unp(4, k) = tbl(i, 5) 'suffix + unp(5, k) = tbl(i, 6) 'container + unp(6, k) = m + 1 'volume break + unp(7, k) = tbl(i, 7 + m) 'price + unp(8, k) = i 'orig row + unp(9, k) = 7 + m 'orig col + Next m + Next i + unp(0, 0) = "stlc" + unp(1, 0) = "coltier" + unp(2, 0) = "branding" + unp(3, 0) = "accs" + unp(4, 0) = "suffix" + unp(5, 0) = "container" + unp(6, 0) = "volume" + unp(7, 0) = "price" + unp(8, 0) = "orig_row" + unp(9, 0) = "orig_col" + + + If Not x.TBLp_TestNumeric(unp, 7) Then + MsgBox ("price is text") + Exit Sub + End If + + unp = x.TBLp_Transpose(unp) + unv = x.TBLp_StringToVar(unp) + + '-------------------------prepare sql to upload--------------------------------------------------------------- + + 'sql = x.SQLp_build_sql_values(unp, False, True, Db2, False) + sql = x.json_from_table(unv, "", False) + sql = "SELECT * FROM rlarp.build_f20_suff($$" & sql & "$$::jsonb)" + Call wapi.ClipBoard_SetData(sql) + + 'If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub + 'Exit Sub + login.Show + If Not login.proceed Then Exit Sub + + + If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, login.tbU.Text, login.tbP.Text, "Port=5030;Database=ubm") Then + MsgBox ("not able to connect to CMS" & vbCrLf & x.ADOo_errstring) + Exit Sub + End If + + cms_pl = x.ADOp_SelectS(0, sql, True, 50000, True) + + Call x.ADOp_CloseCon(0) + + 'Exit Sub + + '--------------------------setup an output sheet if necessary------------------------------- + + For Each ws In Application.Worksheets + For Each cp In ws.CustomProperties + If cp.Name = "spec_name" And cp.value = "price_list" Then + Set new_sh = ws + Exit For + End If + Next cp + Next ws + + If new_sh Is Nothing Then + Set new_sh = Application.Worksheets.Add + Call new_sh.CustomProperties.Add("spec_name", "price_list") + new_sh.Name = "Price Build" + End If + + '-------------------------dump contents------------------------------------------------------ + + Call x.SHTp_Dump(cms_pl, new_sh.Name, 1, 1, True, True) + new_sh.Select + ActiveSheet.Cells(1, 1).CurrentRegion.Select + Selection.Columns.AutoFit + + Rows("1:1").Select + With ActiveWindow + .SplitColumn = 0 + .SplitRow = 1 + End With + ActiveWindow.FreezePanes = True + + + '--------------------------format source cells for any build issues-------------------------------- + + orig.Worksheet.Select + + With orig.Interior + .Pattern = xlNone + .TintAndShade = 0 + .PatternTintAndShade = 0 + End With + + 'if a cell has even one valid hit, don't show an error + 'create a copy of tbl + 'the default value for cell is error, if any good values are found, they stay + + j = 0 + For i = 1 To UBound(cms_pl, 1) + Select Case cms_pl(i, 15) + Case "" + orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor = xlThemeColorAccent6 + Case "No UOM Conversion" + If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then + orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161) + End If + Case "Inactive" + If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then + orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 20, 161) + End If + Case "No SKU" + If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then + orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(20, 255, 161) + End If + End Select + 'if the current row/column is OK, advance to the next row/column + j = 0 + Do Until cms_pl(i, 13) <> cms_pl(i + j, 13) Or cms_pl(i, 14) <> cms_pl(i + j, 14) + j = j + 1 + If i + j >= UBound(cms_pl, 1) Then Exit Do + Loop + i = i + j - 1 '-1 becuase the "next i" will increment by 1 again + Next i + + Dim cell As Range + + For Each cell In Application.Selection.Cells + 'if the cell fill is green, then a known good part was found, so cell to blank + If cell.Interior.ThemeColor = xlThemeColorAccent6 Then + cell.Interior.Pattern = xlNone + Else + If cell.Interior.Pattern = xlNone And cell.value <> "" Then + cell.Interior.Color = RGB(255, 255, 161) + End If + End If + 'if at this point the cell has no background, then there is no part, so highlight it, but only if a price is listed + Next cell + + Selection.Columns(1).Interior.Pattern = xlNone + Selection.Columns(2).Interior.Pattern = xlNone + Selection.Columns(3).Interior.Pattern = xlNone + Selection.Columns(4).Interior.Pattern = xlNone + Selection.Columns(5).Interior.Pattern = xlNone + Selection.Columns(6).Interior.Pattern = xlNone + Selection.Rows(1).Interior.Pattern = xlNone + + + '----------------------------cleanup------------------------------------------------------------- + + Set x = Nothing + + ini.Select + + End Sub Sub go_to_price_issue() @@ -1469,122 +1304,8 @@ Sub go_to_price_issue() End Sub -Sub build_price_upload() - Dim x As New TheBigOne - Dim pl() As String - Dim i As Long - Dim j As Long - Dim ul() As String - Dim pl_code As String - Dim pl_action As String - Dim dtl_action As String - Dim pl_d1 As String - 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)) - -PRICELIST_SHOW: - - pricelist.Show - - 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.cbLIST.value) > 5 Then - MsgBox ("price code must be 5 or less characters") - GoTo PRICELIST_SHOW - End If - - If Not pricelist.cbInactive Then - Call x.TBLp_FilterSingle(pl, 11, "I", False) - End If - - If Not pricelist.cbNonStocked Then - 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 - ul(2, 0) = pl_code - ul(3, 0) = Left(pl_d1, 30) - ul(4, 0) = Left(pl_d2, 30) - ul(5, 0) = Left(pl_d3, 30) - ul(6, 0) = "Y" - ul(7, 0) = "N" - 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(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(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 - - ReDim Preserve ul(11, j) - - - '--------Open file------------- - - If Not x.FILEp_CreateCSV(pricelist.tbPATH.Text & "\" & Replace(pl_code, ".", "_") & ".csv", ul) Then - MsgBox ("error") - End If - - Excel.Workbooks.Open (pricelist.tbPATH.Text & "\" & Replace(pl_code, ".", "_") & ".csv") - - '---------------------header row--------------------------------- - - -End Sub - - - -Sub build_price_upload_r2() +Sub build_price_upload_suff() Dim x As New TheBigOne Dim pl() As String @@ -1628,10 +1349,14 @@ PRICELIST_SHOW: GoTo PRICELIST_SHOW End If + '--------------remove any lines with errors------------- If Not pricelist.cbInactive Then - Call x.TBLp_FilterSingle(pl, 11, "I", False) + Call x.TBLp_FilterSingle(pl, 16, "", True) End If + '--------------remove empty price lines----------------- + Call x.TBLp_FilterSingle(pl, 13, "", False) + If Not pricelist.cbNonStocked Then Call x.TBLp_FilterSingle(pl, 8, "A", True) End If @@ -1707,3 +1432,4 @@ PRICELIST_SHOW: End Sub + diff --git a/pricelist.frm b/pricelist.frm index c35f072..db6ac27 100644 --- a/pricelist.frm +++ b/pricelist.frm @@ -1,10 +1,10 @@ VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} pricelist Caption = "Price List Name" - ClientHeight = 7680 + ClientHeight = 7995 ClientLeft = 120 ClientTop = 465 - ClientWidth = 8895.001 + ClientWidth = 11865 OleObjectBlob = "pricelist.frx":0000 StartUpPosition = 1 'CenterOwner End @@ -48,15 +48,19 @@ Private Sub bPICK_Click() End Sub +Private Sub cbInactive_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) + Me.tbD1 = plc(1, 1) + Me.tbD2 = plc(2, 1) + Me.tbD3 = plc(3, 1) End Sub @@ -76,8 +80,9 @@ Private Sub lbLIST_Click() End Sub Private Sub UserForm_Initialize() + + proceed = False - Dim x() As Variant Dim i As Long ReDim x(3) @@ -96,17 +101,22 @@ 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 +' If login.tbP = "" Then +' login.Show +' If Not login.proceed Then Exit Sub +' If Not FL.x.ADOp_OpenCon(0, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@041") Then +' MsgBox (FL.x.ADOo_errstring) +' Exit Sub +' End If +' End If + + If Not FL.x.ADOp_OpenCon(1, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@042") Then + MsgBox (FL.x.ADOo_errstring) + Exit Sub 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) + 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) ReDim plv(1 To UBound(pl, 2)) For i = 1 To UBound(pl, 2) plv(i) = pl(0, i) @@ -120,7 +130,7 @@ Private Sub UserForm_Initialize() 'lbHEAD.ColumnCount = lbHist.ColumnCount 'lbHEAD.ColumnWidths = lbHist.ColumnWidths - Call FL.x.frmListBoxHeader(lbHEAD, lbLIST, "plcode", "func", "basis", "tier", "currency", "d1") + Call FL.x.frmListBoxHeader(lbHEAD, lbLIST, "plcode", "descr1", "descr2", "descr3") End Sub @@ -129,4 +139,55 @@ Private Sub UserForm_Terminate() proceed = False End Sub +Sub load_lists() + + Dim x() As Variant + Dim i As Long + ReDim x(3) + + x(1) = "1 - New" + x(2) = "2 - Replace" + x(3) = "3 - Update" + + Dim dtl() As Variant + ReDim dtl(3) + 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, "PTROWBRIDG", "QQQX53@041") Then +' MsgBox (FL.x.ADOo_errstring) +' Exit Sub +' End If +' End If + + If Not FL.x.ADOp_OpenCon(1, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@042") Then + MsgBox (FL.x.ADOo_errstring) + Exit Sub + End If + + 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) + 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", "d1", "d2", "d3") +End Sub diff --git a/pricelist.frx b/pricelist.frx index 2601fe8..d97b7ae 100644 Binary files a/pricelist.frx and b/pricelist.frx differ