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

updates

Browse Source
This commit is contained in:
Paul Trowbridge 2023-04-27 07:36:19 -04:00
parent 4f45a6b3f3
commit 0b8e18e666
8 changed files with 323 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

196
FL.bas
View File

@ -561,7 +561,7 @@ Sub sql_from_range_pg_noqh()
Dim wapi As New Windows_API
Dim r() As String
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, False, "S", "S", "S", "S", "A"))
End Sub
@ -793,7 +793,7 @@ Sub extract_price_matrix()
If Not login.proceed Then Exit Sub
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm") Then
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
@ -1012,7 +1012,7 @@ Sub extract_price_matrix_suff()
If Not login.proceed Then Exit Sub
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm") Then
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
@ -1341,7 +1341,7 @@ Sub price_load_pcore()
ReDim Preserve pcol(pcount)
ReDim typeflag(9)
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5432;Database=ubm") Then
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then
MsgBox (Err.Description)
Exit Sub
End If
@ -1535,7 +1535,7 @@ Sub nursery_parse()
' sql = tbo.ADOp_BuildInsertSQL(ext, "rlarp.nregional", True, 1, UBound(ext, 2), Array("S", "S", "N", "S"))
' sql = "truncate table rlarp.nregional;" & vbCrLf & sql & ";"
' If Not tbo.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5432;Database=ubm") Then
' If Not tbo.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then
' MsgBox (tbo.ADOo_errstring)
' Else
' MsgBox ("Uploaded")
@ -1560,10 +1560,10 @@ Sub pricegroup_upload()
Dim sql As String
Selection.CurrentRegion.Select
sql = x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, True, "S", "S", "S", "S", "S", "S", "S", "S", "S", "N", "S", "S", "S", "A", "A", "J")
sql = x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, True, "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "A", "A", "J")
sql = "BEGIN;" & vbCrLf & "DELETE FROM rlarp.price_map;" & vbCrLf & "INSERT INTO rlarp.price_map" & vbCrLf & sql & ";" & vbCrLf & "COMMIT;"
If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5432;Database=ubm") Then
If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "10.56.60.254", False, "ptrowbridge", "qqqx53!030", "Port=5432;Database=ubm") Then
MsgBox (x.ADOo_errstring)
Exit Sub
Else
@ -1572,7 +1572,7 @@ Sub pricegroup_upload()
Call x.ADOp_CloseCon(0)
sql = x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, True, "S", "S", "S", "S", "S", "S", "S", "S", "S", "N", "S", "S", "S", "A", "A", "A")
sql = x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, True, "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "A", "A", "A")
sql = "BEGIN" & vbCrLf & "DELETE FROM rlarp.price_map;" & vbCrLf & "INSERT INTO rlarp.price_map" & vbCrLf & sql & ";" & vbCrLf & "END"
If Not x.ADOp_Exec(0, sql, 1, True, ADOinterface.SqlServer, "usmidsql01", True) Then
@ -1626,7 +1626,7 @@ Sub pricegroup_upload_db2()
inc = 250
Do While i <= UBound(ul, 2)
'sql = x.ADOp_BuildInsertSQL(ul, "rlarp.price_map", True, i, WorksheetFunction.Min(i + inc, UBound(ul, 2)), Array("S", "S", "S", "S", "S", "S", "S", "N", "S", "S"))
sql = x.SQLp_build_sql_values_ranged(ul, True, True, Db2, False, True, i, i + inc, "S", "S", "S", "S", "S", "S", "S", "S", "S", "N", "S", "S", "S", "A", "A", "A")
sql = x.SQLp_build_sql_values_ranged(ul, True, True, Db2, False, True, i, i + inc, "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "A", "A", "A")
sql = "INSERT INTO rlarp.price_map " & vbCrLf & sql
If Not x.ADOp_Exec(0, sql) Then
MsgBox (x.ADOo_errstring)
@ -1660,4 +1660,182 @@ Sub clear_page_breaks()
End Sub
Sub load_ffterr()
Dim x As New TheBigOne
Dim sql As String
login.Show
If Not login.proceed Then Exit Sub
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, login.tbU, login.tbP, "database=ubm") Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
sql = "BEGIN; DELETE FROM IMPORT.FFTERR; INSERT INTO import.FFTERR"
sql = sql & vbLf & x.SQLp_build_sql_values(x.SHTp_Get("FFTERR", 1, 1, True), False, True, PostgreSQL, False, True, "S", "S", "S", "S", "J") & ";"
sql = sql & vbLf & "DELETE FROM rlarp.ffterr; INSERT INTO rlarp.ffterr SELECT * FROM import.ffterr; END;"
If Not x.ADOp_Exec(0, sql) Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
MsgBox ("Complete")
End Sub
Sub load_ffcret()
Dim x As New TheBigOne
Dim sql As String
login.Show
If Not login.proceed Then Exit Sub
If Not x.ADOp_OpenCon(0, ISeries, "S7830956", False, login.tbU, login.tbP) Then
Exit Sub
End If
sql = "BEGIN DELETE FROM RLARP.FFCRET; INSERT INTO RLARP.FFCRET"
sql = sql & vbLf & x.SQLp_build_sql_values(x.SHTp_Get("FFCRET", 1, 1, True), False, True, Db2, False, True, "S", "S", "S", "S", "N") & ";"
sql = sql & vbLf & "END"
If Not x.ADOp_Exec(0, sql) Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
MsgBox ("Complete")
End Sub
Sub load_csrca()
Dim x As New TheBigOne
Dim sql As String
login.Show
If Not login.proceed Then Exit Sub
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, login.tbU, login.tbP, "database=ubm") Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
sql = "BEGIN; DELETE FROM IMPORT.CSRCA; INSERT INTO import.CSRCA"
sql = sql & vbLf & x.SQLp_build_sql_values(x.SHTp_Get("CSRCA", 1, 1, True), False, True, PostgreSQL, False, True, "S", "S", "S", "S", "J") & ";"
sql = sql & vbLf & "DELETE FROM rlarp.csrca; INSERT INTO rlarp.csrca SELECT * FROM import.csrca; END;"
If Not x.ADOp_Exec(0, sql) Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
MsgBox ("Complete")
End Sub
Sub load_prm()
Dim x As New TheBigOne
Dim sql As String
login.Show
If Not login.proceed Then Exit Sub
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, login.tbU, login.tbP, "database=ubm") Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
sql = "BEGIN; DELETE FROM IMPORT.PRM; INSERT INTO import.prm"
sql = sql & vbLf & x.SQLp_build_sql_values(x.SHTp_Get("prm", 1, 1, True), False, True, PostgreSQL, False, True, "A", "A") & ";"
sql = sql & vbLf & "DELETE FROM rlarp.prm; INSERT INTO rlarp.prm SELECT * FROM import.prm; END;"
If Not x.ADOp_Exec(0, sql) Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
MsgBox ("Complete")
End Sub
Sub load_qrh()
Dim x As New TheBigOne
Dim sql As String
login.Caption = "Postgres Creds"
login.Show
If Not login.proceed Then Exit Sub
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, login.tbU, login.tbP, "database=ubm") Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
login.Caption = "iSeries Creds"
login.Show
If Not login.proceed Then Exit Sub
If Not x.ADOp_OpenCon(1, ISeries, "S7830956", False, login.tbU, login.tbP) Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
sql = "BEGIN; DELETE FROM IMPORT.QRH; INSERT INTO import.qrh"
sql = sql & vbLf & x.SQLp_build_sql_values(x.SHTp_Get("qrh", 1, 1, True), False, True, PostgreSQL, False, True, "A", "A") & ";"
sql = sql & vbLf & "DELETE FROM rlarp.qrh; INSERT INTO rlarp.qrh SELECT * FROM import.qrh; END;"
If Not x.ADOp_Exec(0, sql) Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
sql = "BEGIN DELETE FROM RLARP.QRH; INSERT INTO RLARP.QRH" & vbCrLf
sql = sql & x.SQLp_build_sql_values(x.SHTp_Get("qrh", 1, 1, True), True, True, Db2, False, True, "A", "A") & ";"
sql = sql & vbCrLf & " END"
If Not x.ADOp_Exec(1, sql) Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
End Sub
Sub load_index()
Dim x As New TheBigOne
Dim sql As String
login.Caption = "Postgres Creds"
login.Show
If Not login.proceed Then Exit Sub
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidsap01", False, login.tbU, login.tbP, "database=ubm") Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
sql = "BEGIN; DELETE FROM IMPORT.COSTINDEX; INSERT INTO import.costindex"
sql = sql & vbLf & x.SQLp_build_sql_values(x.SHTp_Get("INDEX", 1, 1, True), False, True, PostgreSQL, False, True, "J", "DR", "N") & ";"
sql = sql & vbLf & "DELETE FROM rlarp.costindex; INSERT INTO rlarp.costindex SELECT * FROM import.costindex; END;"
If Not x.ADOp_Exec(0, sql) Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
End Sub

53
PriceLists.bas
View File

@ -43,7 +43,7 @@ Sub test_full20()
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=5432;Database=ubm") Then
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm") Then
MsgBox ("not able to connect to CMS" & vbCrLf & x.ADOo_errstring)
Exit Sub
End If
@ -251,7 +251,7 @@ Sub price_load_plcore()
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=5432;Database=ubm") Then
If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU, login.tbP, "Port=5432;Database=ubm") Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
@ -475,6 +475,7 @@ End Function
Sub build_customer_files()
Dim x As New TheBigOne
Dim i As Long
Dim pl() As String
Dim pln() As String
Dim plf() As String
@ -497,22 +498,56 @@ Sub build_customer_files()
login.Caption = "PostgreSQL Login"
login.tbU = "report"
login.tbP = "report"
login.Show
login.proceed = True
'login.Show
If Not login.proceed Then Exit Sub
Call pricelevel.repopulate
pricelevel.Show
If pricelevel.cancel Then Exit Sub
plev = pricelevel.tbPriceLev.text
If Not IsDate(pricelevel.tbEddDate.text) Then
MsgBox ("cannot interperet date - " & pricelevel.tbEddDate.text)
Exit Sub
End If
For i = 0 To pricelevel.lbPriceLev.ListCount - 1
If pricelevel.lbPriceLev.Selected(i) Then
plev = pricelevel.lbPriceLev.list(i)
Call build_price_level(plev)
End If
Next i
End Sub
Sub build_price_level(plev As String)
Dim x As New TheBigOne
Dim i As Long
Dim pl() As String
Dim pln() As String
Dim plf() As String
Dim fc() As String
Dim nwb As Workbook
Dim fcwb As Workbook
Dim nws As Worksheet
Dim nnws As Worksheet
Dim nfws As Worksheet
Dim fcws As Worksheet
Dim filepath As String
Dim effdate As Date
Dim clist() As String
Dim segment_regex As String
Dim curr As String
Dim fname As String
effdate = CDate(pricelevel.tbEddDate.text)
filepath = pricelevel.tbPATH & "\" & plev
If pricelevel.chbFULLCODE Then
'---------------------get full code list--------------------------------------------------------------------
fc = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_fullcode_cust('" & plev & "', '" & effdate & "'::date)", False, 20000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
fc = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_fullcode_cust('" & plev & "', '" & effdate & "'::date)", False, 20000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
If fc(0, 0) <> "Currency" Then
MsgBox (fc(0, 0))
Exit Sub
@ -520,7 +555,7 @@ Sub build_customer_files()
'---------------------create new workbook-------------------------------------------------------------------
If UBound(fc, 2) = 0 Then
MsgBox ("no full code list data for " & plev)
'MsgBox ("no full code list data for " & plev)
Exit Sub
End If
Application.ScreenUpdating = False
@ -588,7 +623,7 @@ Sub build_customer_files()
'---------------------get price list------------------------------------------------------------------------
If pricelevel.chbNURSERY Then
pln = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "', '^N')", False, 2000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
pln = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "', '^N')", False, 2000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
If pln(0, 0) <> "Product" Then
MsgBox (pln(0, 0))
Exit Sub
@ -602,7 +637,7 @@ Sub build_customer_files()
End If
If pricelevel.chbFIBER Then
plf = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','^F')", False, 2000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
plf = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','^F')", False, 2000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
If plf(0, 0) <> "Product" Then
MsgBox (plf(0, 0))
Exit Sub
@ -619,7 +654,7 @@ Sub build_customer_files()
End If
End If
pl = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','" & segment_regex & "')", False, 2000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
pl = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','" & segment_regex & "')", False, 2000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
If pl(0, 0) <> "Product" Then
MsgBox (pl(0, 0))
Exit Sub

17
TheBigOne.cls
View File

@ -2193,7 +2193,7 @@ Function json_concat(list As Range) As String
End Function
Public Function ADOp_BuildInsertSQL(ByRef tbl() As String, target As String, trim As Boolean, start As Long, ending As Long, ParamArray ftype()) As String
Public Function ADOp_BuildInsertSQL(ByRef tbl() As String, Target As String, trim As Boolean, start As Long, ending As Long, ParamArray ftype()) As String
Dim i As Long
@ -2202,7 +2202,7 @@ Public Function ADOp_BuildInsertSQL(ByRef tbl() As String, target As String, tri
Dim sql As String
Dim rec As String
sql = "INSERT INTO " & target & " VALUES " & vbCrLf
sql = "INSERT INTO " & Target & " VALUES " & vbCrLf
For i = start To ending
rec = ""
If i <> start Then sql = sql & "," & vbCrLf
@ -2621,6 +2621,17 @@ Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, he
rec = rec & "'" & Replace(tbl(j, i), "'", "''") & "'::jsonb"
End If
End If
Case "DR" '-------no regex and cast to daterange---------------------------
rx.Pattern = strip_text
If LTrim(RTrim(tbl(j, i))) = "" And empty_as_null Then
rec = rec & "CAST(NULL AS jsonb)"
Else
If trim Then
rec = rec & "'" & Replace(LTrim(RTrim(tbl(j, i))), "'", "''") & "'::daterange"
Else
rec = rec & "'" & Replace(tbl(j, i), "'", "''") & "'::daterange"
End If
End If
Case "D" '-------D = date---------------------------------------------
rx.Pattern = strip_date
If LTrim(RTrim(tbl(j, i))) = "" Then
@ -2872,7 +2883,7 @@ Public Function Misc_ConvBase10(ByVal d As Double, ByVal sNewBaseDigits As Strin
Dim s As String, tmp As Double, i As Integer, lastI As Integer
Dim BaseSize As Integer
BaseSize = Len(sNewBaseDigits)
Do While Val(d) <> 0
Do While val(d) <> 0
tmp = d
i = 0
Do While tmp >= BaseSize

BIN
login.frx
View File

Binary file not shown.

15
pricelevel.frm
View File

@ -1,10 +1,10 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} pricelevel
Caption = "Build Customer Price List"
ClientHeight = 7920
ClientHeight = 9975.001
ClientLeft = 120
ClientTop = 465
ClientWidth = 8775.001
ClientWidth = 10620
OleObjectBlob = "pricelevel.frx":0000
StartUpPosition = 1 'CenterOwner
End
@ -70,12 +70,17 @@ End Sub
Sub repopulate()
Dim i As Long
Dim j As Long
Dim numRows As Long
Dim numCols As Long
Dim colWidths() As Long
Dim lbColumnWidths As String
Dim pl() As String
pl = x.SHTp_Get("Price Levels", 3, 1, True)
Call x.TBLp_FilterSingle(pl, 3, 0, False)
Me.lbPriceLev.list = x.TBLp_StringToVar(x.TBLp_Transpose(pl))
Dim i As Long
For i = 1 To lbPriceLev.ListCount - 1
If lbPriceLev.list(i, 0) = Selection Then
lbPriceLev.Selected(i) = True
@ -84,7 +89,7 @@ Sub repopulate()
End If
Next i
tbEddDate.text = "06/01/2022"
tbEddDate.text = "03/01/2023"
End Sub

BIN
pricelevel.frx
View File

Binary file not shown.

BIN
pricelist.frx
View File

Binary file not shown.

193
targets.bas
View File

@ -11,23 +11,62 @@ Sub get_options()
Set ws = ActiveSheet
Dim sql As String
mold = ws.Cells(2, 1)
Dim onfile() As String
Dim merge() As String
Dim i As Long
Dim fpath As String
'If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then Exit Sub
With ws.Cells.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'----------------get the available options from all the parts setup in the item master----------------------------------------------
sql = "SELECT * FROM rlarp.get_options('" & mold & "');"
res = x.ADOp_SelectS(0, sql, True, 100, True, PostgreSQLODBC, "10.56.60.254", False, "report", "report", "Port=5432;Database=ubm")
ws.Range("M1:AD350").ClearContents
Call x.SHTp_Dump(res, ws.Name, 1, 13, False, True, 15)
ws.Range("N1:ZZ3500").ClearContents
sql = "SELECT * FROM rlarp.get_option_costs('" & mold & "');"
'----------------get the options already set if this item has been setup------------------------------------------------------------
fpath = Sheets("env").Range("B1").value & "\" & Sheets("combine").Range("A2").value & "\options.csv"
If Len(Dir(fpath)) > 0 Then
onfile = x.FILEp_GetCSV(fpath)
Call x.ARRAYp_Transpose(onfile)
'merge all the options from the item master and the saved options
merge = x.TBLp_JoinTbls(onfile, res, True, True, 2, Array(0, 1, 3), Array(0, 1, 3), Array(2))
Call x.SHTp_Dump(merge, ws.Name, ws.Cells(ws.Rows.Count, 14).End(xlUp).row, 14, False, True, 15)
'loop through each result and highlight cells that only exist on the saved file and not the item master
'the last column indicated if the option is on the item master
i = 1
Do Until ws.Cells(i, 14) = ""
If ws.Cells(i, 18) = "" Then
With ws.Cells(i, 16).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
i = i + 1
Loop
'get rid of the column used to flag for color
ws.Columns(18).ClearContents
Else
Call x.SHTp_Dump(res, ws.Name, 1, 14, False, True, 15)
End If
sql = "SELECT * FROM rlarp.get_option_costs('" & mold & "') ORDER BY branding, coltier, uomp;"
res = x.ADOp_SelectS(0, sql, True, 100, True, PostgreSQLODBC, "10.56.60.254", False, "report", "report", "Port=5432;Database=ubm")
ws.Range("C1:K350").ClearContents
ws.Range("C1:L350").ClearContents
Call x.SHTp_Dump(res, ws.Name, 1, 3, False, True, 8)
Call x.ADOp_CloseCon(0)
End Sub
Sub combine_options()
@ -44,22 +83,24 @@ Sub combine_options()
Set ws = ActiveSheet
mold = ws.Cells(2, 1)
stack = x.SHTp_GetString(ws.Range("L1"))
stack = x.SHTp_GetString(ws.Range("N1"))
stack = x.TBLp_Transpose(stack)
stackv = x.TBLp_StringToVar(stack)
json = x.json_from_table(stackv, "", False)
sql = "SELECT * FROM rlarp.set_options($$" & vbCrLf & json & vbCrLf & "$$::jsonb)"
res = x.ADOp_SelectS(0, sql, True, 5000, True, PostgreSQLODBC, "usmidlnx01", False, "report", "", "Port=5030;Database=ubm")
res = x.ADOp_SelectS(0, sql, True, 5000, True, PostgreSQLODBC, "10.56.60.254", False, "report", "report", "Port=5432;Database=ubm")
Call x.ADOp_CloseCon(0)
ws.Range("R1:AD5000").ClearContents
Call x.SHTp_Dump(res, ws.Name, 1, 18, False, True)
ws.Range("S1:AC5000").ClearContents
Call x.SHTp_Dump(res, ws.Name, 1, 19, False, True)
End Sub
Sub save_targets()
Call targets.combine_options
Dim path As String
Dim opt() As String
Dim tar() As String
@ -68,6 +109,9 @@ Sub save_targets()
Dim sqlt As String
Dim targt As String
Dim i As Long
Dim x As New TheBigOne
Dim wapi As New Windows_API
Dim tbl() As Variant
'create 3 files:
'* options listing
@ -76,8 +120,8 @@ Sub save_targets()
Set ws = ActiveSheet
opt = x.SHTp_Get(ws.Name, 1, 13, True)
tar = x.SHTp_Get(ws.Name, 1, 18, True)
opt = x.SHTp_Get(ws.Name, 1, 14, True)
tar = x.SHTp_Get(ws.Name, 1, 19, True)
path = Sheets("env").Cells(1, 2) & "\" & ActiveSheet.Cells(2, 1) & "\options.csv"
If Not x.FILEp_CreateCSV(path, opt) Then
@ -97,7 +141,7 @@ Sub save_targets()
sqlt = sqlt & sql(0, i) & vbCrLf
Next i
targt = x.SQLp_build_sql_values(x.SHTp_Get(ws.Name, 1, 18, True), True, True, PostgreSQL, False, True, "N", "N", "S", "S", "S", "S", "S", "S", "N", "N", "N", "N", "N")
targt = x.SQLp_build_sql_values(x.SHTp_Get(ws.Name, 1, 19, True), True, True, PostgreSQL, False, True, "N", "N", "S", "S", "S", "S", "S", "S", "N", "N", "N", "N", "N")
sqlt = Replace(sqlt, "replace_this", targt)
@ -113,7 +157,7 @@ Sub save_targets()
sqlt = sqlt & sql(0, i) & vbCrLf
Next i
targt = x.SQLp_build_sql_values(x.SHTp_Get(ws.Name, 1, 18, True), True, True, PostgreSQL, False, True, "N", "N", "S", "S", "S", "S", "S", "S", "N", "N", "N", "N", "N")
targt = x.SQLp_build_sql_values(x.SHTp_Get(ws.Name, 1, 19, True), True, True, PostgreSQL, False, True, "N", "N", "S", "S", "S", "S", "S", "S", "N", "N", "N", "N", "N")
sqlt = Replace(sqlt, "replace_this", targt)
@ -121,126 +165,21 @@ Sub save_targets()
Exit Sub
End If
If Not x.ADOp_Exec(0, sqlt, 1, True, PostgreSQLODBC, "usmidsap01", False, "report", "report", "Port=5432;Database=ubm") Then
MsgBox (x.ADOo_errstring)
Else
Call x.ADOp_CloseCon(0)
End If
'Dim Foldername As String
'Foldername = Sheets("env").Cells(1, 2) & "\" & ActiveSheet.Cells(2, 1)
'Shell "C:\WINDOWS\explorer.exe """ & Foldername & "", vbNormalFocus
ws.Cells(1, 14).CurrentRegion.Select
tbl = Selection
End Sub
Sub get_options_old()
Dim brd() As String
Dim pck() As String
Dim acc() As String
Dim col() As String
Dim sfx() As String
Dim c As Object
Dim mold As String
Set ws = ActiveSheet
mold = ws.Cells(2, 1)
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then Exit Sub
brd = x.ADOp_SelectS(0, "select distinct substring(branding,1,1) ""Branding"", 0 ""Price"" from rlarp.itemmv where stlc = '" & mold & "'", True, 50, True)
pck = x.ADOp_SelectS(0, "select distinct uomp->>0 ""Packaging"", 0 ""Price"" from rlarp.itemmv where stlc = '" & mold & "'", True, 50, True)
acc = x.ADOp_SelectS(0, "select distinct accs_ps ""Accessories"", 0 ""Price"" from rlarp.itemmv where stlc = '" & mold & "'", True, 50, True)
col = x.ADOp_SelectS(0, "select distinct coltier ""Color Tier"", 0 ""Facor"" from rlarp.itemmv where stlc = '" & mold & "'", True, 50, True)
sfx = x.ADOp_SelectS(0, "select distinct suffix ""Suffix"" ,0 ""Factor"" from rlarp.itemmv where stlc = '" & mold & "'", True, 50, True)
Call x.ADOp_CloseCon(0)
ws.Range("E1:I35").ClearContents
Call x.SHTp_Dump(brd, ws.Name, 1, 5, False, True)
Call x.SHTp_Dump(pck, ws.Name, 6, 5, False, True)
Call x.SHTp_Dump(acc, ws.Name, 13, 5, False, True)
Call x.SHTp_Dump(col, ws.Name, 1, 8, False, True)
Call x.SHTp_Dump(sfx, ws.Name, 16, 8, False, True)
For Each c In ws.Range("F2:F30")
If (IsNumeric(c.value) And c.value <> "") Then c.value = CDbl(c.value)
Next c
For Each c In ws.Range("I2:I30")
If (IsNumeric(c.value) And c.value <> "") Then c.value = CDbl(c.value)
Next c
Call wapi.ClipBoard_SetData(x.markdown_from_table(tbl))
End Sub
Sub push_options_old()
Dim brd() As String
Dim pkg() As String
Dim acc() As String
Dim col() As String
Dim sfx() As String
Dim mold As String
Dim stack() As String
Dim i As Long
Dim j As Long
Set ws = ActiveSheet
mold = ws.Cells(2, 1)
brd = x.SHTp_GetString(ws.Range("E1"))
pkg = x.SHTp_GetString(ws.Range("E6"))
acc = x.SHTp_GetString(ws.Range("E13"))
col = x.SHTp_GetString(ws.Range("H1"))
sfx = x.SHTp_GetString(ws.Range("H16"))
j = 2
ReDim stack(3, UBound(brd, 2) + UBound(pkg, 2) + UBound(acc, 2) + UBound(col, 2) + UBound(sfx, 2) - 5 + 1)
stack(0, 0) = "entity"
stack(1, 0) = "attr"
stack(2, 0) = "val"
stack(3, 0) = "func"
stack(0, 1) = "Anchor"
stack(1, 1) = mold
stack(2, 1) = ws.Cells(2, 2)
stack(3, 1) = "Price"
For i = 2 To UBound(brd, 2)
stack(0, j) = "Branding"
stack(1, j) = brd(1, i)
stack(2, j) = brd(2, i)
stack(3, j) = brd(2, 1)
j = j + 1
Next i
For i = 2 To UBound(pkg, 2)
stack(0, j) = "Packaging"
stack(1, j) = pkg(1, i)
stack(2, j) = pkg(2, i)
stack(3, j) = pkg(2, 1)
j = j + 1
Next i
For i = 2 To UBound(acc, 2)
stack(0, j) = "Accessories"
stack(1, j) = acc(1, i)
stack(2, j) = acc(2, i)
stack(3, j) = acc(2, 1)
j = j + 1
Next i
For i = 2 To UBound(col, 2)
stack(0, j) = "Color Tier"
stack(1, j) = col(1, i)
stack(2, j) = col(2, i)
stack(3, j) = col(2, 1)
j = j + 1
Next i
For i = 2 To UBound(sfx, 2)
stack(0, j) = "Suffix"
stack(1, j) = sfx(1, i)
stack(2, j) = sfx(2, i)
stack(3, j) = sfx(2, 1)
j = j + 1
Next i
ws.Range("L1:O100").ClearContents
Call x.SHTp_Dump(stack, ws.Name, 1, 12, False, True, 14)
End Sub