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, "usmidsap02", 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 DirectoryExists(fpath) 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, "usmidsap02", False, "report", "report", "Port=5432;Database=ubm") ws.Range("C1:L350").ClearContents Call x.SHTp_Dump(res, ws.Name, 1, 3, False, True, 9, 10, 11) Call x.ADOp_CloseCon(0) End Sub Function DirectoryExists(directory As String) As Boolean On Error GoTo ErrorHandler Dim tempDir As String tempDir = Dir(directory, vbDirectory) DirectoryExists = (tempDir <> "") Exit Function ErrorHandler: 'If there is any error (e.g. invalid path), return False DirectoryExists = False End Function 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, "usmidsap02", 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, "usmidsap02", 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