563 lines
16 KiB
QBasic
563 lines
16 KiB
QBasic
Attribute VB_Name = "TargetGroups"
|
|
' Declare the API function to read from INI
|
|
Declare PtrSafe Function GetPrivateProfileString Lib "kernel32" _
|
|
Alias "GetPrivateProfileStringA" ( _
|
|
ByVal lpAppName As String, _
|
|
ByVal lpKeyName As String, _
|
|
ByVal lpDefault As String, _
|
|
ByVal lpReturnedString As String, _
|
|
ByVal nSize As Long, _
|
|
ByVal lpFileName As String) As Long
|
|
|
|
' Helper to read from ini
|
|
Function ReadINI(section As String, key As String, filepath As String) As String
|
|
|
|
Dim buffer As String * 1024
|
|
Dim length As Long
|
|
length = GetPrivateProfileString(section, key, "", buffer, Len(buffer), filepath)
|
|
ReadINI = Left(buffer, length)
|
|
|
|
End Function
|
|
|
|
|
|
|
|
Sub ReadConfig()
|
|
|
|
Dim basePath As String
|
|
Dim folderName As String
|
|
Dim targetFolder As String
|
|
Dim configPath As String
|
|
Dim reviewGroup As String
|
|
Dim regexPattern As String
|
|
Dim volumeCode As String
|
|
Dim statusCode As String
|
|
Dim fso As Object
|
|
|
|
On Error GoTo HandleError
|
|
|
|
Set fso = CreateObject("Scripting.FileSystemObject")
|
|
|
|
' === 1. Get paths from sheets ===
|
|
basePath = trim(Sheets("env").Range("B1").value)
|
|
If basePath = "" Then
|
|
MsgBox "Error: Base path (env!B1) is blank.", vbExclamation
|
|
Exit Sub
|
|
End If
|
|
If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
|
|
|
|
folderName = trim(Sheets("combine").Cells(2, 1).value)
|
|
If folderName = "" Then
|
|
MsgBox "Error: No folder name in combine!A2.", vbExclamation
|
|
Exit Sub
|
|
End If
|
|
|
|
targetFolder = basePath & folderName & "\"
|
|
configPath = targetFolder & "config.ini"
|
|
|
|
' === 2. Check that folder exists ===
|
|
If Not fso.FolderExists(targetFolder) Then
|
|
MsgBox "Folder not found: " & targetFolder, vbExclamation
|
|
Exit Sub
|
|
End If
|
|
|
|
' === 3. Check that config.ini exists ===
|
|
If Not fso.FileExists(configPath) Then
|
|
MsgBox "config.ini not found in: " & targetFolder, vbExclamation
|
|
Exit Sub
|
|
End If
|
|
|
|
' === 4. Read values from INI ===
|
|
reviewGroup = ReadINI("Filter", "ReviewGroup", configPath)
|
|
regexPattern = ReadINI("Filter", "ProductFamilyRegex", configPath)
|
|
volumeCode = ReadINI("Filter", "VolumeUOM", configPath)
|
|
statusCode = ReadINI("Filter", "StatusCode", configPath)
|
|
|
|
' === 5. Handle empty values with fallback ===
|
|
If reviewGroup = "" Then reviewGroup = "(not defined)"
|
|
If regexPattern = "" Then regexPattern = "(not defined)"
|
|
If volumeCode = "" Then volumeCode = "GAL"
|
|
If statusCode = "" Then statusCode = "FALSE"
|
|
|
|
' === 6. Write results to Excel cells ===
|
|
Sheets("combine").Range("A2").value = reviewGroup
|
|
Sheets("combine").Range("A5").value = regexPattern
|
|
Sheets("combine").Range("A8").value = volumeCode
|
|
Sheets("combine").Range("A11").value = statusCode
|
|
|
|
' === 7. Load options ===
|
|
Call LoadOptionsAndCosts
|
|
Exit Sub
|
|
|
|
' === Error handling ===
|
|
HandleError:
|
|
MsgBox "Error in LoadConfigINI_ReadOnly: " & Err.Description, vbExclamation
|
|
End Sub
|
|
|
|
Sub WriteConfig()
|
|
Dim basePath As String
|
|
Dim folderName As String
|
|
Dim targetFolder As String
|
|
Dim configPath As String
|
|
Dim volumeCode As String
|
|
Dim statusCode As String
|
|
Dim fso As Object
|
|
Dim ts As Object
|
|
|
|
' Values to write
|
|
Dim reviewGroup As String
|
|
Dim regexPattern As String
|
|
|
|
On Error GoTo HandleError
|
|
|
|
Set fso = CreateObject("Scripting.FileSystemObject")
|
|
|
|
' === 1. Get base path from env!B1 ===
|
|
basePath = trim(Sheets("env").Range("B1").value)
|
|
If basePath = "" Then
|
|
MsgBox "Error: Base path in env!B1 is blank.", vbExclamation
|
|
Exit Sub
|
|
End If
|
|
If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
|
|
|
|
' === 2. Get folder name from combine!A2 ===
|
|
folderName = trim(Sheets("combine").Cells(2, 1).value)
|
|
If folderName = "" Then
|
|
MsgBox "Error: No folder name in combine!A2.", vbExclamation
|
|
Exit Sub
|
|
End If
|
|
|
|
targetFolder = basePath & folderName & "\"
|
|
configPath = targetFolder & "config.ini"
|
|
|
|
' === 3. Get config values from Excel ===
|
|
reviewGroup = folderName
|
|
regexPattern = trim(Sheets("combine").Cells(5, 1).value)
|
|
If regexPattern = "" Then regexPattern = ".*" ' default fallback
|
|
volumeCode = trim(Sheets("combine").Cells(8, 1).value)
|
|
statusCode = trim(Sheets("combine").Cells(11, 1).value)
|
|
|
|
' === 4. Ensure target folder exists ===
|
|
If Not fso.FolderExists(targetFolder) Then
|
|
fso.CreateFolder targetFolder
|
|
End If
|
|
|
|
' === 5. Always write (overwrite) config.ini ===
|
|
Set ts = fso.CreateTextFile(configPath, True, False)
|
|
ts.WriteLine "[Filter]"
|
|
ts.WriteLine "ReviewGroup = " & reviewGroup
|
|
ts.WriteLine "ProductFamilyRegex = " & regexPattern
|
|
ts.WriteLine "VolumeUOM = " & volumeCode
|
|
ts.WriteLine "StatusCode = " & statusCode
|
|
ts.Close
|
|
|
|
' === 6. Done silently ===
|
|
Call ListTargetFolders
|
|
Exit Sub
|
|
|
|
HandleError:
|
|
MsgBox "Error in WriteConfigFromExcel:" & vbCrLf & Err.Description, vbExclamation
|
|
|
|
Call ListTargetFolders
|
|
|
|
End Sub
|
|
|
|
|
|
Sub ListTargetFolders()
|
|
|
|
Dim basePath As String
|
|
Dim fso As Object, folder As Object, subfolder As Object
|
|
Dim ws As Worksheet
|
|
Dim i As Long
|
|
Dim folderListRange As Range
|
|
|
|
' Read path from env!B1
|
|
basePath = Sheets("env").Range("B1").value
|
|
If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
|
|
|
|
Set fso = CreateObject("Scripting.FileSystemObject")
|
|
|
|
If Not fso.FolderExists(basePath) Then
|
|
MsgBox "Base path not found: " & basePath, vbExclamation
|
|
Exit Sub
|
|
End If
|
|
|
|
Set folder = fso.GetFolder(basePath)
|
|
Set ws = Sheets("env")
|
|
|
|
' Clear old list
|
|
ws.Range("A4:A100").ClearContents
|
|
i = 4
|
|
|
|
' Write folder names
|
|
For Each subfolder In folder.SubFolders
|
|
ws.Cells(i, 1).value = subfolder.Name
|
|
i = i + 1
|
|
Next
|
|
|
|
' Always clear any old named range first
|
|
On Error Resume Next
|
|
ThisWorkbook.Names("TargetFolderList").Delete
|
|
On Error GoTo 0
|
|
|
|
' Only create the named range if we found folders
|
|
If i > 4 Then
|
|
Set folderListRange = ws.Range("A4").Resize(i - 4)
|
|
ActiveWorkbook.Names.Add Name:="TargetFolderList", RefersTo:="=" & ws.Name & "!" & folderListRange.address
|
|
End If
|
|
|
|
|
|
End Sub
|
|
|
|
Sub LoadOptionsAndCosts()
|
|
|
|
Const COL_FOLDER As Long = 1
|
|
Const ROW_FOLDER As Long = 2
|
|
Const COL_REGEX As Long = 1
|
|
Const ROW_REGEX As Long = 5
|
|
|
|
Dim ws As Worksheet
|
|
Dim res() As String
|
|
Dim onfile() As String
|
|
Dim csvTable As Variant
|
|
Dim optionsJSON As String
|
|
Dim pricegroup As String
|
|
Dim folder As String
|
|
Dim sql As String
|
|
Dim fpath As String
|
|
Dim i As Long
|
|
Dim x As New TheBigOne
|
|
Dim fso As Object
|
|
|
|
On Error GoTo HandleError
|
|
|
|
Set ws = ActiveSheet
|
|
Set fso = CreateObject("Scripting.FileSystemObject")
|
|
|
|
' === Read mold (regex) and folder ===
|
|
pricegroup = trim(ws.Cells(ROW_REGEX, COL_REGEX).value)
|
|
folder = trim(ws.Cells(ROW_FOLDER, COL_FOLDER).value)
|
|
|
|
If pricegroup = "" Then
|
|
MsgBox "Error: No regex pattern provided in cell A5.", vbExclamation
|
|
Exit Sub
|
|
End If
|
|
|
|
' === Build the CSV path ===
|
|
fpath = Sheets("env").Range("B1").value
|
|
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
|
|
fpath = fpath & folder & "\options.csv"
|
|
|
|
' === Build optionsJSON ===
|
|
If fso.FileExists(fpath) Then
|
|
onfile = x.FILEp_GetCSV(fpath)
|
|
csvTable = onfile
|
|
optionsJSON = x.json_from_table(csvTable, "", True)
|
|
Else
|
|
optionsJSON = "[]"
|
|
End If
|
|
|
|
' === 1. dump the CSV directly ===
|
|
ws.Range("P2:ZZ50000").ClearContents
|
|
If optionsJSON <> "[]" Then
|
|
onfile = x.TBLp_Transpose(onfile)
|
|
Call x.SHTp_Dump(onfile, ws.Name, 1, 16, False, True, 2)
|
|
End If
|
|
|
|
' === 2. Get option costs ===
|
|
sql = "SELECT * FROM rlarp.get_option_costs_priceg('" & Replace(pricegroup, "'", "''") & "') " & _
|
|
"ORDER BY branding, coltier, uomp;"
|
|
res = x.ADOp_SelectS(0, sql, True, 10000, True, PostgreSQLODBC, _
|
|
"usmidsap02", False, "report", "report", "Port=5432;Database=ubm")
|
|
ws.Range("C2:N50000").ClearContents
|
|
Call x.SHTp_Dump(res, ws.Name, 1, 3, False, True, 7, 8, 9, 10, 11)
|
|
|
|
Cleanup:
|
|
On Error Resume Next
|
|
Call x.ADOp_CloseCon(0)
|
|
Exit Sub
|
|
|
|
HandleError:
|
|
MsgBox "Error in LoadOptionsAndCosts: " & Err.Description, vbExclamation
|
|
Resume Cleanup
|
|
|
|
End Sub
|
|
|
|
|
|
Sub WriteTargets()
|
|
|
|
' === Constants for easy maintenance ===
|
|
Const COL_FOLDER As Long = 1
|
|
Const ROW_FOLDER As Long = 2
|
|
Const COL_PRICEGROUP As Long = 1
|
|
Const ROW_PRICEGROUP As Long = 5
|
|
|
|
Dim ws As Worksheet
|
|
Dim x As New TheBigOne
|
|
Dim wapi As New Windows_API
|
|
Dim fso As Object
|
|
Dim opt() As String
|
|
Dim tar() As String
|
|
Dim sql() As String
|
|
Dim sqlt As String
|
|
Dim targt As String
|
|
Dim i As Long
|
|
Dim tbl() As Variant
|
|
Dim basePath As String
|
|
Dim folderName As String
|
|
Dim targetFolder As String
|
|
Dim optionsPath As String
|
|
Dim mergeTemplatePath As String
|
|
Dim mergeOutputPath As String
|
|
|
|
On Error GoTo HandleError
|
|
|
|
Call WriteConfig
|
|
|
|
Set ws = ActiveSheet
|
|
Set fso = CreateObject("Scripting.FileSystemObject")
|
|
|
|
' === 1. Get base path and folder name from sheets ===
|
|
basePath = trim(Sheets("env").Cells(1, 2).value)
|
|
If basePath = "" Then
|
|
MsgBox "Error: Base path in env!B1 is blank.", vbExclamation
|
|
Exit Sub
|
|
End If
|
|
If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
|
|
|
|
folderName = trim(ws.Cells(ROW_FOLDER, COL_FOLDER).value)
|
|
If folderName = "" Then
|
|
MsgBox "Error: Folder name in A2 is blank.", vbExclamation
|
|
Exit Sub
|
|
End If
|
|
|
|
targetFolder = basePath & folderName & "\"
|
|
|
|
' === 2. Ensure target folder exists ===
|
|
If Not fso.FolderExists(targetFolder) Then
|
|
fso.CreateFolder targetFolder
|
|
End If
|
|
|
|
' === 3. Create options.csv ===
|
|
opt = x.SHTp_Get(ws.Name, 1, 16, True)
|
|
optionsPath = targetFolder & "options.csv"
|
|
If Not x.FILEp_CreateCSV(optionsPath, opt) Then
|
|
MsgBox "Error: Failed to create options.csv", vbExclamation
|
|
Exit Sub
|
|
End If
|
|
|
|
Exit Sub
|
|
|
|
HandleError:
|
|
MsgBox "Error in WriteTargets: " & Err.Description, vbExclamation
|
|
Exit Sub
|
|
|
|
End Sub
|
|
|
|
|
|
|
|
Sub BuildPricingPath()
|
|
|
|
Const COL_FOLDER As Long = 1
|
|
Const ROW_FOLDER As Long = 2
|
|
Const COL_REGEX As Long = 1
|
|
Const ROW_REGEX As Long = 5
|
|
|
|
Dim ws As Worksheet
|
|
Dim res() As String
|
|
Dim onfile() As String
|
|
Dim csvTable As Variant
|
|
Dim optionsJSON As String
|
|
Dim pricegroup As String
|
|
Dim folder As String
|
|
Dim sql As String
|
|
Dim fpath As String
|
|
Dim i As Long
|
|
Dim x As New TheBigOne
|
|
Dim fso As Object
|
|
|
|
On Error GoTo HandleError
|
|
|
|
Set ws = ActiveSheet
|
|
Set fso = CreateObject("Scripting.FileSystemObject")
|
|
|
|
' === Read regex and folder ===
|
|
pricegroup = trim(ws.Cells(ROW_REGEX, COL_REGEX).value)
|
|
folder = trim(ws.Cells(ROW_FOLDER, COL_FOLDER).value)
|
|
|
|
If folder = "" Then
|
|
MsgBox "Error: No folder name in A2.", vbExclamation
|
|
Exit Sub
|
|
End If
|
|
|
|
' === Build CSV path ===
|
|
fpath = Sheets("env").Range("B1").value
|
|
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
|
|
fpath = fpath & folder & "\options.csv"
|
|
|
|
' === Build options JSON ===
|
|
If fso.FileExists(fpath) Then
|
|
onfile = x.FILEp_GetCSV(fpath)
|
|
csvTable = onfile
|
|
optionsJSON = x.json_from_table(csvTable, "", True)
|
|
Else
|
|
optionsJSON = "[]"
|
|
End If
|
|
|
|
' === 1. Call Postgres NEW FUNCTION ===
|
|
sql = "SELECT attr, ds, chan, tier, vol, agg FROM pricequote.build_pricing_path(" & _
|
|
"'" & Replace(optionsJSON, "'", "''") & "') WHERE lastflag"
|
|
|
|
res = x.ADOp_SelectS(0, sql, True, 50000, True, PostgreSQLODBC, _
|
|
"usmidsap02", False, "report", "report", "Port=5432;Database=ubm")
|
|
|
|
ws.Range("V:ZZ").ClearContents
|
|
Call x.SHTp_Dump(res, ws.Name, 1, 22, False, True, 5)
|
|
|
|
|
|
Cleanup:
|
|
On Error Resume Next
|
|
Call x.ADOp_CloseCon(0)
|
|
Exit Sub
|
|
|
|
HandleError:
|
|
MsgBox "Error in BuildPricingPath: " & Err.Description, vbExclamation
|
|
Resume Cleanup
|
|
|
|
End Sub
|
|
|
|
|
|
Sub BuildOptionsAndCosts()
|
|
|
|
Const COL_FOLDER As Long = 1
|
|
Const ROW_FOLDER As Long = 2
|
|
Const COL_REGEX As Long = 1
|
|
Const ROW_REGEX As Long = 5
|
|
|
|
Dim ws As Worksheet
|
|
Dim res() As String
|
|
Dim onfile() As String
|
|
Dim csvTable As Variant
|
|
Dim optionsJSON As String
|
|
Dim pricegroup As String
|
|
Dim folder As String
|
|
Dim sql As String
|
|
Dim fpath As String
|
|
Dim i As Long
|
|
Dim x As New TheBigOne
|
|
Dim fso As Object
|
|
|
|
On Error GoTo HandleError
|
|
|
|
Set ws = ActiveSheet
|
|
Set fso = CreateObject("Scripting.FileSystemObject")
|
|
|
|
' === Read mold (regex) and folder ===
|
|
pricegroup = trim(ws.Cells(ROW_REGEX, COL_REGEX).value)
|
|
folder = trim(ws.Cells(ROW_FOLDER, COL_FOLDER).value)
|
|
|
|
If pricegroup = "" Then
|
|
MsgBox "Error: No regex pattern provided in cell A5.", vbExclamation
|
|
Exit Sub
|
|
End If
|
|
|
|
' === Build the CSV path ===
|
|
fpath = Sheets("env").Range("B1").value
|
|
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
|
|
fpath = fpath & folder & "\options.csv"
|
|
|
|
' === Build optionsJSON ===
|
|
If fso.FileExists(fpath) Then
|
|
onfile = x.FILEp_GetCSV(fpath)
|
|
csvTable = onfile
|
|
optionsJSON = x.json_from_table(csvTable, "", True)
|
|
Else
|
|
optionsJSON = "[]"
|
|
End If
|
|
|
|
' === 1. Call Postgres for merged options ===
|
|
sql = "SELECT * FROM rlarp.get_options_merged(" & _
|
|
"'" & Replace(pricegroup, "'", "''") & "', " & _
|
|
"'" & Replace(optionsJSON, "'", "''") & "');"
|
|
|
|
res = x.ADOp_SelectS(0, sql, True, 10000, True, PostgreSQLODBC, _
|
|
"usmidsap02", False, "report", "report", "Port=5432;Database=ubm")
|
|
ws.Range("P:ZZ").ClearContents
|
|
Call x.SHTp_Dump(res, ws.Name, ws.Cells(ws.Rows.Count, 16).End(xlUp).row, 16, False, True, 2)
|
|
|
|
' === 2. Get option costs ===
|
|
sql = "SELECT * FROM rlarp.get_option_costs_priceg('" & Replace(pricegroup, "'", "''") & "') " & _
|
|
"ORDER BY branding, coltier, uomp;"
|
|
res = x.ADOp_SelectS(0, sql, True, 10000, True, PostgreSQLODBC, _
|
|
"usmidsap02", False, "report", "report", "Port=5432;Database=ubm")
|
|
ws.Range("C:N").ClearContents
|
|
Call x.SHTp_Dump(res, ws.Name, 1, 3, False, True, 7, 8, 9, 10, 11)
|
|
|
|
Cleanup:
|
|
On Error Resume Next
|
|
Call x.ADOp_CloseCon(0)
|
|
Exit Sub
|
|
|
|
HandleError:
|
|
MsgBox "Error in LoadOptionsAndCosts: " & Err.Description, vbExclamation
|
|
Resume Cleanup
|
|
|
|
End Sub
|
|
|
|
|
|
Sub GetProductInfo()
|
|
|
|
Const COL_INPUT As Long = 1
|
|
Const ROW_INPUT As Long = 5
|
|
|
|
Dim ws As Worksheet
|
|
Dim res() As String
|
|
Dim productCode As String
|
|
Dim volumeCode As String
|
|
Dim sql As String
|
|
Dim x As New TheBigOne
|
|
Dim qry As Worksheet
|
|
|
|
On Error GoTo HandleError
|
|
|
|
Set ws = Sheets("combine")
|
|
Set qry = Sheets("Products")
|
|
|
|
' === Read product code from A5 ===
|
|
productCode = trim(ws.Cells(ROW_INPUT, COL_INPUT).value)
|
|
volumeCode = trim(ws.Cells(8, 1).value)
|
|
|
|
If productCode = "" Then
|
|
MsgBox "Error: No product code provided in cell A5.", vbExclamation
|
|
Exit Sub
|
|
End If
|
|
|
|
' === Build SQL to call Postgres function ===
|
|
sql = "SELECT * FROM rlarp.get_product_info(" & _
|
|
"'" & Replace(productCode, "'", "''") & "', " & _
|
|
"'" & Replace(volumeCode, "'", "''") & "');"
|
|
|
|
' === Call Postgres ===
|
|
res = x.ADOp_SelectS(0, sql, True, 10000, True, PostgreSQLODBC, _
|
|
"usmidsap02", False, "report", "report", "Port=5432;Database=ubm")
|
|
|
|
' === Clear previous output ===
|
|
qry.Range("A:ZZ").ClearContents
|
|
|
|
' === Dump results starting at column A ===
|
|
Call x.SHTp_Dump(res, qry.Name, 1, 1, False, True, 4, 5)
|
|
|
|
qry.Activate
|
|
|
|
Cleanup:
|
|
On Error Resume Next
|
|
Call x.ADOp_CloseCon(0)
|
|
Exit Sub
|
|
|
|
HandleError:
|
|
MsgBox "Error in GetProductInfo: " & Err.Description, vbExclamation
|
|
Resume Cleanup
|
|
|
|
End Sub
|
|
|
|
|