VBA/targets.bas

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