'******************************************************************************************************************************************** '* Script: Cumulative Total.iss '* Author: Brian Element - brian.element@ideascripting.com '* Date: May 11, 2016 '* Purpose: This script will allow you to create a cumulative total or percent field. It also allows you to select an index to base this cumulative total on. '* This script is presented without any warranty or guarantee. Users are encouraged to validate the effectiveness and reliability on their own. '******************************************************************************************************************************************** Dim listbox1$() Dim field1$() Dim direction1$() Begin Dialog dlgCumulativeTotal 22,10,316,180,"Cumulative Total", .displayIt Text 10,10,201,14, "Text", .Text1 PushButton 222,10,15,10, "...", .PushButton1 GroupBox 7,5,210,22, .GroupBox1 Text 10,30,40,10, "Select Field", .Text2 DropListBox 10,44,200,14, listbox1$(), .DropListBox1 OKButton 18,110,40,14, "OK", .OKButton1 CancelButton 84,110,40,14, "Cancel", .CancelButton1 GroupBox 10,61,120,34, "Accumulate by", .GroupBox2 OptionGroup .OptionButtonGroup1 OptionButton 18,75,40,14, "Amount", .OptionButton1 OptionButton 78,75,40,14, "Percentage", .OptionButton2 PushButton 147,70,40,15, "Index", .PushButton2 End Dialog Begin Dialog dlgIndex 50,45,258,211,"Index", .funIndexDlg DropListBox 10,20,160,10, field1$(), .FieldListBox1 Text 75,4,40,10, "Field", .Text2 Text 186,4,40,10, "Direction", .Text1 DropListBox 185,20,40,14, direction1$(), .DirectionListBox1 DropListBox 10,35,160,11, field1$(), .FieldListBox2 DropListBox 10,50,160,10, field1$(), .FieldListBox3 DropListBox 10,65,160,11, field1$(), .FieldListBox4 DropListBox 10,80,160,11, field1$(), .FieldListBox5 DropListBox 10,95,160,10, field1$(), .FieldListBox6 DropListBox 10,110,160,10, field1$(), .FieldListBox7 DropListBox 10,125,160,10, field1$(), .FieldListBox8 OKButton 26,150,40,14, "OK", .OKButton1 CancelButton 85,150,40,14, "Cancel", .CancelButton1 DropListBox 185,35,40,10, direction1$(), .DirectionListBox2 DropListBox 185,50,40,10, direction1$(), .DirectionListBox3 DropListBox 185,65,40,11, direction1$(), .DirectionListBox4 DropListBox 185,80,40,10, direction1$(), .DirectionListBox5 DropListBox 185,95,40,10, direction1$(), .DirectionListBox6 DropListBox 185,110,40,10, direction1$(), .DirectionListBox7 DropListBox 185,125,40,11, direction1$(), .DirectionListBox8 End Dialog Option Explicit Dim sFilename As String Dim sFieldname As String Dim bTotalType As Boolean Dim bExitScript As Boolean Dim working_directory As String Dim dlg As dlgCumulativeTotal Dim dlg1 As dlgIndex Dim sNewFieldName As String Dim sIndexFields(7) As String Dim sIndexDirection(7) As String Dim bDialogOpen As Boolean Sub Main working_directory = Client.WorkingDirectory() Call menu() If Not bExitScript Then Call createField() Call addInfo() Call addHistory() Client.OpenDatabase(sFilename) MsgBox "Script Complete" Else MsgBox "Script Cancelled" End If End Sub Function addHistory() Dim db As database Dim thisHistory As History Dim i As Integer Set db = client.OpenDatabase(sFilename) Set thisHistory = db.History thisHistory.NewTask "Add Cumulative Total" thisHistory.AppendDatabaseInfo thisHistory.DateStamp If bTotalType Then thisHistory.AppendText "Cumulative Type", "Percentage" Else thisHistory.AppendText "Cumulative Type", "Amount" End If thisHistory.AppendText "File", sFilename thisHistory.AppendText "Field Selected", sFieldname thisHistory.AppendText "Field Created", sNewFieldName For i = 0 To 7 If sIndexFields(i) <> "" Then thisHistory.AppendText "Index " & (i + 1), sIndexFields(i) & ", " & sIndexDirection(i) End If Next i Set thisHistory = Nothing db.close Set db = Nothing End Function Function addInfo() Dim db As database Dim table As table Dim field As field Dim stats As Object Dim rs As Object Dim rec As Object Dim dCumAmt As Double Dim dPercAmt As Double Dim i As Long Dim dAmtTotal As Double Set db = Client.OpenDatabase(sFilename) 'make sure that the stats have been computed Set stats = db.FieldStats(sFieldname) If Not stats.computed Then stats.ComputeStats End If dAmtTotal = stats.NetValue() Set stats = Nothing Set table = db.TableDef Set field = table.GetField(sNewFieldName) field.Protected = False Set rs = db.RecordSet For i = 0 To 7 If sIndexFields(i) <> "" Then rs.AddKey sIndexFields(i) , sIndexDirection(i) End If Next i rs.ToFirst For i = 1 To db.count rs.Next Set rec = rs.ActiveRecord If bTotalType Then 'percentage dPercAmt= (rec.GetNumValue(sFieldname) / dAmtTotal ) * 100 dCumAmt = dCumAmt + dPercAmt Else dCumAmt = dCumAmt + rec.GetNumValue(sFieldname) End If rec.SetNumValue sNewFieldName, dCumAmt rs.SaveRecord rec Next i Set rec = Nothing field.Protected = True Set field = Nothing Set rs = Nothing Set table = Nothing Set db = Nothing End Function Function createField() Dim db As database Dim task As task Dim table As table Dim field As field Dim eqn As String Dim iDecimals As Integer If bTotalType Then 'percentage sNewFieldName = sFieldname & "_CUMULATIVE_PERC" Else sNewFieldName = sFieldname & "_CUMULATIVE_AMT" End If sNewFieldName = checkIfFieldNameExists(sNewFieldName, sFilename) If bTotalType Then 'percentage iDecimals = 3 Else Set db = Client.OpenDatabase(sFilename) Set table = db.TableDef Set field = table.GetField(sFieldname) iDecimals = field.Decimals Set field = Nothing Set table = Nothing Set db = Nothing End If Set db = Client.OpenDatabase(sFilename) Set task = db.TableManagement Set table = db.TableDef Set field = table.NewField eqn = 0 field.Name = sNewFieldName field.Description = "" field.Type = WI_NUM_FIELD field.Equation = eqn field.Decimals = iDecimals task.AppendField field task.PerformTask Set field = Nothing Set table = Nothing Set task = Nothing Set db = Nothing End Function Function funIndexDlg(ControlID$, Action%, SuppValue%) Dim bExitFunction As Boolean Dim i, j As Integer Dim bDuplicates As Boolean Select Case action% Case 1 For i = 2 To 8 DlgEnable "FieldListBox" & i, 0 DlgEnable "DirectionListBox" & i, 0 Next i ReDim direction1$(1) direction1$(0) = "Ascending" direction1$(1) = "Descending" For i = 1 To 8 DlgListBoxArray "DirectionListBox" & i, direction1$ DlgListBoxArray "FieldListBox" & i, field1$ Next i Case 2 Select Case ControlID$ Case "OKButton1" 'get the info If DlgValue("FieldListBox1") = 0 Then MsgBox "Please select at least one field to index on" Else For i = 1 To 8 If DlgEnable("FieldListBox" & i) = 0 Then DlgEnable("FieldListBox" & i), 1 If DlgValue("FieldListBox" & i) <> 0 Then sIndexFields(i - 1) = field1$(DlgValue("FieldListBox" & i)) If DlgValue("DirectionListBox" & i) = 0 Then sIndexDirection(i - 1) = "A" Else sIndexDirection(i - 1) = "D" End If End If Else sIndexFields(i - 1) = "" DlgEnable("FieldListBox" & i), 0 End If Next i 'check to make sure there are no duplicates bDuplicates = False For i = 0 To 7 For j = 0 To 7 If i <> j And sIndexFields(i) <> "" Then If sIndexFields(i) = sIndexFields(j) Then bDuplicates = True End If End If Next j Next i If bDuplicates Then MsgBox "You cannot have duplicate index entries" Else bExitFunction = true End If End If Case "CancelButton1" For i = 0 To 7 sIndexFields(i) = "" bExitFunction = true Next i Case "FieldListBox1" Call enableDialogs(2, SuppValue% ) Case "FieldListBox2" Call enableDialogs(3, SuppValue% ) Case "FieldListBox3" Call enableDialogs(4, SuppValue% ) Case "FieldListBox4" Call enableDialogs(5, SuppValue% ) Case "FieldListBox5" Call enableDialogs(6, SuppValue% ) Case "FieldListBox6" Call enableDialogs(7, SuppValue% ) Case "FieldListBox7" Call enableDialogs(8, SuppValue% ) End Select End Select 'DlgText "Text3", "Action: " & Action% & " Control ID: " & ControlID$ & " Supp Value: " & SuppValue% If bExitFunction Then funIndexDlg = 0 Else funIndexDlg = 1 End If End Function Function enableDialogs(iItem As Integer, iSuppValue) Dim i As Integer If iSuppValue <> 0 Then DlgEnable "FieldListBox" & iItem, 1 DlgEnable "DirectionListBox" & iItem, 1 Else For i = iItem To 8 DlgEnable "FieldListBox" & i, 0 DlgEnable "DirectionListBox" & i, 0 Next i End If End Function Function DisplayIt(ControlID$, Action%, SuppValue%) Dim bExitFunction As Boolean Dim button As Integer Dim i As Integer Select Case Action% Case 1 bDialogOpen = False If sFilename <> "" Then If populateDropDown() Then DlgListBoxArray "DropListBox1", listbox1$() Else sFilename = "" End If End If Case 2 Select Case ControlID$ Case "PushButton1" sFilename = getFile() If sFilename <> "" Then If populateDropDown() Then DlgListBoxArray "DropListBox1", listbox1$() Else sFilename = "" End If Else ReDim listbox1$(0) DlgListBoxArray "DropListBox1", listbox1$() End If Case "PushButton2" If Not bDialogOpen Then bDialogOpen = true dlgEnable "okButton1", 0 dlgEnable "CancelButton1", 0 button = Dialog(dlg1) 'if x button selected to cancel forget any index fields If button = 0 Then For i = 0 To 7 sIndexFields(i) = "" Next i End If bDialogOpen = false dlgEnable "okButton1", 1 dlgEnable "CancelButton1", 1 End If Case "CancelButton1" bExitScript = True bExitFunction = True Case "okButton1" If Not bDialogOpen Then If sFilename = "" Then MsgBox "Please select a file" Else sFieldname = listbox1$(DlgValue("DropListBox1")) bTotalType = dlgCumulativeTotal.OptionButtonGroup1 bExitFunction = true End If End If End Select End Select If sFilename = "" Then DlgText "Text1", "Please select a file" Else DlgText "Text1", getFileName(sFilename, 0) End If If bExitFunction Then DisplayIt = 0 Else DisplayIt = 1 End If End Function Function menu() 'Dim dlg As dlgCumulativeTotal Dim button As Integer On Error Resume Next sFilename = client.CurrentDatabase.Name If err.number <> 0 Then err.number = 0 End If button = Dialog(dlg) If button = 0 Then bExitScript = True End Function Function populateDropDown() As Boolean Dim db As database Dim table As table Dim field As field Dim i As Integer Dim bFirstTime As Boolean bFirstTime = true ReDim listbox1$(0) Set db = client.OpenDatabase(sFilename) Set table = db.TableDef ReDim field1$(table.count) field1$(0) = "Please Select" For i = 1 To table.count Set field = table.GetFieldAt(i) field1$(i) = field.name If field.IsNumeric Then If bFirstTime Then bFirstTime = False listbox1$(0) = field.name Else ReDim preserve listbox1$(UBound(listbox1$) + 1) listbox1$(UBound(listbox1$)) = field.name End If End If Set field = Nothing Next i Set table = Nothing Set db = Nothing If bFirstTime Then 'no numeric fields in file MsgBox "There are no numeric fields in this file" populateDropDown = false Else Call sortArray(listbox1$) populateDropDown = true End If Call sortArrayField(field1$) End Function Private Function sortArray(MyArray() As String) Dim lLoop, lLoop2 As Integer Dim str1, str2 As String For lLoop = 0 To UBound(MyArray) For lLoop2 = lLoop To UBound(MyArray) If UCase(MyArray(lLoop2)) < UCase(MyArray(lLoop)) Then str1 = MyArray(lLoop) str2 = MyArray(lLoop2) MyArray(lLoop) = str2 MyArray(lLoop2) = str1 End If Next lLoop2 Next lLoop End Function Private Function sortArrayField(MyArray() As String) Dim lLoop, lLoop2 As Integer Dim str1, str2 As String For lLoop = 1 To UBound(MyArray) For lLoop2 = lLoop To UBound(MyArray) If UCase(MyArray(lLoop2)) < UCase(MyArray(lLoop)) Then str1 = MyArray(lLoop) str2 = MyArray(lLoop2) MyArray(lLoop) = str2 MyArray(lLoop2) = str1 End If Next lLoop2 Next lLoop End Function Function getFileName(temp_filename As String, temp_type As Boolean) '1 if get the name with any folder info, 0 if only the name Dim temp_length As Integer Dim temp_len_wd As Integer Dim temp_difference As Integer Dim temp_char As String Dim tempfilename As String If temp_type Then temp_len_wd = Len(working_directory ) + 1'get the lenght of the working directory temp_length = Len(temp_filename) 'get the lenght of the file along with the working directory temp_difference = temp_length - temp_len_wd + 1'get the lenght of just the filename getFileName = Mid(temp_filename, temp_len_wd, temp_difference) Else temp_length = Len(temp_filename ) Do temp_char = Mid(temp_filename, temp_length , 1) temp_length = temp_length - 1 If temp_char <> "\" Then tempfilename = temp_char & tempfilename End If Loop Until temp_char = "\" Or temp_length = 0 getFileName = tempfilename End If End Function Function getFile() Dim filebar As Object Set filebar =CreateObject ("ideaex.FileExplorer") ' Display the File Explorer filebar.DisplayDialog ' Set Variable to store Select File Name getFile = filebar.SelectedFile End Function Function checkIfFieldNameExists(fieldname As String, filename As String) As String Dim db As database Dim table As table Dim field As field Dim i, j, field_count As Integer Dim fieldNames() As String 'array to hold the field names Dim fieldNameOk As Boolean Dim origFieldName As String fieldname = UCase(fieldname) origFieldName = fieldname Set db = Client.OpenDatabase(filename) Set table = db.TableDef field_count = table.count 'get the number for fields ReDim fieldNames(field_count) 'populate the array to obtain all the field names For i = 1 To field_count Set field = table.GetFieldAt(i) fieldNames(i) = field.name Next i j = 1 'loop until we find a fieldname that doesn't exit Do For i = 1 To field_count If fieldname = fieldNames(i) Then fieldname = origFieldName & j j = j + 1 fieldNameOk = FALSE Exit For Else fieldNameOk = true End If Next i Loop While fieldNameOk = FALSE checkIfFieldNameExists = fieldname Set field = Nothing Set table = Nothing Set db = Nothing End Function