VBA/targets.bas

247 lines
7.6 KiB
QBasic

Attribute VB_Name = "targets"
Option Explicit
Public ws As Worksheet
Public x As New TheBigOne
Sub get_options()
Dim res() As String
Dim mold As String
Set ws = ActiveSheet
Dim sql As String
mold = ws.Cells(2, 1)
'If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then Exit Sub
sql = "SELECT * FROM rlarp.get_options('" & mold & "');"
res = x.ADOp_SelectS(0, sql, True, 100, True, PostgreSQLODBC, "usmidlnx01", False, "report", "", "Port=5030;Database=ubm")
ws.Range("M1:P350").ClearContents
Call x.SHTp_Dump(res, ws.Name, 1, 13, False, True, 15)
sql = "SELECT * FROM rlarp.get_option_costs('" & mold & "');"
res = x.ADOp_SelectS(0, sql, True, 100, True, PostgreSQLODBC, "usmidlnx01", False, "report", "", "Port=5030;Database=ubm")
ws.Range("C1:K350").ClearContents
Call x.SHTp_Dump(res, ws.Name, 1, 3, False, True, 8)
Call x.ADOp_CloseCon(0)
End Sub
Sub combine_options()
Dim mold As String
Dim stack() As String
Dim stackv() As Variant
Dim res() As String
Dim i As Long
Dim j As Long
Dim sql As String
Dim json As String
Set ws = ActiveSheet
mold = ws.Cells(2, 1)
stack = x.SHTp_GetString(ws.Range("L1"))
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")
Call x.ADOp_CloseCon(0)
ws.Range("R1:AD5000").ClearContents
Call x.SHTp_Dump(res, ws.Name, 1, 18, False, True)
End Sub
Sub save_targets()
Dim path As String
Dim opt() As String
Dim tar() As String
Dim ws As Worksheet
Dim sql() As String
Dim sqlt As String
Dim targt As String
Dim i As Long
'create 3 files:
'* options listing
'* list of targets as csv
'* list of targets embedded in sql for merge
Set ws = ActiveSheet
opt = x.SHTp_Get(ws.Name, 1, 13, True)
tar = x.SHTp_Get(ws.Name, 1, 18, True)
path = Sheets("env").Cells(1, 2) & "\" & ActiveSheet.Cells(2, 1) & "\options.csv"
If Not x.FILEp_CreateCSV(path, opt) Then
MsgBox ("file creation error")
Exit Sub
End If
path = Sheets("env").Cells(1, 2) & "\" & ActiveSheet.Cells(2, 1) & "\targ.csv"
If Not x.FILEp_CreateCSV(path, tar) Then
MsgBox ("file creation error")
Exit Sub
End If
'--------------------mssql merge----------------------------
sql() = x.FILEp_GetTXT(Sheets("env").Cells(1, 2) & "\000\merge.sql", 1000)
For i = LBound(sql, 2) To UBound(sql, 2)
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, "N", "N", "S", "S", "S", "S", "S", "S", "N", "N", "N", "N", "N")
sqlt = Replace(sqlt, "replace_this", targt)
If Not x.FILEp_Create(Sheets("env").Cells(1, 2) & "\" & ActiveSheet.Cells(2, 1) & "\merge.sql", sqlt) Then
Exit Sub
End If
'--------------------postgres merge----------------------------
sql() = x.FILEp_GetTXT(Sheets("env").Cells(1, 2) & "\000\merge.pg.sql", 1000)
sqlt = ""
For i = LBound(sql, 2) To UBound(sql, 2)
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, "N", "N", "S", "S", "S", "S", "S", "S", "N", "N", "N", "N", "N")
sqlt = Replace(sqlt, "replace_this", targt)
If Not x.FILEp_Create(Sheets("env").Cells(1, 2) & "\" & ActiveSheet.Cells(2, 1) & "\merge.pg.sql", sqlt) Then
Exit Sub
End If
'Dim Foldername As String
'Foldername = Sheets("env").Cells(1, 2) & "\" & ActiveSheet.Cells(2, 1)
'Shell "C:\WINDOWS\explorer.exe """ & Foldername & "", vbNormalFocus
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
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