VBA/targets.bas
2023-04-27 07:36:19 -04:00

186 lines
6.1 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)
Dim onfile() As String
Dim merge() As String
Dim i As Long
Dim fpath As String
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("N1:ZZ3500").ClearContents
'----------------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:L350").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("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, "10.56.60.254", False, "report", "report", "Port=5432;Database=ubm")
Call x.ADOp_CloseCon(0)
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
Dim ws As Worksheet
Dim sql() As String
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
'* list of targets as csv
'* list of targets embedded in sql for merge
Set ws = ActiveSheet
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
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, 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)
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, 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)
If Not x.FILEp_Create(Sheets("env").Cells(1, 2) & "\" & ActiveSheet.Cells(2, 1) & "\merge.pg.sql", sqlt) Then
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
Call wapi.ClipBoard_SetData(x.markdown_from_table(tbl))
End Sub