Dim FieldList1$() AS string Dim DataList1$() AS string Dim DataList2$() AS string Begin Dialog MainMenu 50,50,200,200,"Summarization", .DisplayIt PushButton 5,5,75,14, "Select Database", .SelectDatabaseButton Text 85,5,75,14, "Text", .ShowDatabaseName PushButton 125,160,60,14, "Exit", .Exit1 TextBox 85,25,75,14, .NewDatabaseName Text 5,25,75,14, "Define new database name", .InfoText1 PushButton 5,160,60,14, "Run Gap Detection", .RunGapDetection Text 5,45,75,10, "Define field to use:", .InfoText2 DropListBox 85,45,75,11, FieldList1$(), .FieldToUse PushButton 5,65,75,14, "Show sample record", .ShowSampleRec DropListBox 85,65,75,11, DataList1$(), .ShowSampleRecord DropListBox 85,80,75,10, DataList2$(), .Show2 End Dialog Begin Dialog AuditTrail 50,50,200,205,"Audittrail", .DisplayIt Text 5,5,180,10, "Text", .Audittrail_A Text 5,20,180,30, "Text", .Audittrail_B Text 5,55,180,10, "Text", .Audittrail_C Text 5,70,180,20, "Text", .Audittrail_D PushButton 75,170,40,14, "Exit", .Exit2 Text 5,95,180,20, "Text", .Audittrail_E Text 5,120,180,15, "Text", .Audittrail_F Text 5,140,180,10, "Text", .Audittrail_G Text 5,155,180,10, "Text", .Audittrail_H End Dialog '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- 'Name: Robert van den Bogaard - 11-09-2018 'Description: Summarization Function 'Last Update: 11-09-2018 '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Option Explicit Dim dlg1 As MainMenu Dim dlg0 As AuditTrail Dim ExitScript As Boolean Dim ExitDialog0 As Boolean Dim ExitDialog1 As Boolean Dim ShowSampleRecord As Boolean Dim WorkingDirectory As String Dim DatabasePad As String Dim DatabaseName As String Dim NewDatabaseName As String Dim Username As String Dim ExecutionDate As String Dim ResultName As String Dim SelectedField1 As String '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Sub Main WorkingDirectory = Client.WorkingDirectory Call Main_Menu() End Sub '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Function Main_Menu() Dim button As Integer button = Dialog(dlg1) client.refreshFileExplorer End Function '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Function AuditTrailMenu() Dim button As Integer button = Dialog(dlg0) End Function '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Function DisplayIt(ControlID$, Action%, SuppValue%) Dim button As Integer Dim i As Integer Select Case Action% Case 1 ShowSampleRecord = False Case 2 Select Case ControlID$ Case "Exit1" ExitDialog1 = True ExitScript = True Case "SelectDatabaseButton" DatabasePad = getFile() DatabaseName = iSplit(DatabasePad, "", "\", 1, 1) ExecutionDate = Now() Username = GetUsername(DatabasePad) Client.CloseAll Call GetFieldsList1() Call sortArray(FieldList1) DlgListBoxArray "FieldToUse", FieldList1$() Case "ShowSampleRec" ShowSampleRecord = False NewDatabaseName = dlg1.NewDatabaseName SelectedField1= FieldList1$(dlg1.FieldToUse + 1) Call Summarization1 Call ExportDatabase1 Call DeleteDatabase1 Call ImportText1 Client.CloseAll ShowSampleRecord = True Case "RunGapDetection" NewDatabaseName = dlg1.NewDatabaseName If validateMenu1() Then End If End Select End Select If DatabaseName <> "" Then DlgText "ShowDatabaseName", iSplit(DatabaseName, "", "\", 1, 1) Else DlgText "ShowDatabaseName", "Select Database" End If If DatabaseName = "" Then DlgText "Audittrail_A", "" Else DlgText "Audittrail_A", "De volgende database is gebruikt = " & DatabaseName End If If DatabasePad = "" Then DlgText "Audittrail_B", "" Else DlgText "Audittrail_B", "De gebruikte database bevindt zich op de volgende locatie = " & DatabasePad End If If NewDatabaseName = "" Then DlgText "Audittrail_C", "" Else DlgText "Audittrail_C", "Nieuwe database naam = " & NewDatabaseName End If If ExecutionDate = "" Then DlgText "Audittrail_H", "" Else DlgText "Audittrail_H", "Analyse uitgevoerd op = " & ExecutionDate End If If Username = "" Then DlgText "Audittrail_G", "" Else DlgText "Audittrail_G", "Analyse uitgevoerd door = " & Username End If If DatabaseName = "" Then DlgEnable "ShowSampleRec", 0 DlgEnable "ShowSampleRecord", 0 DlgEnable "FieldToUse", 0 Else DlgEnable "ShowSampleRec", 1 DlgEnable "FieldToUse", 1 End If If ShowSampleRecord = False Then DlgEnable "ShowSampleRecord", 0 Else DlgEnable "ShowSampleRecord", 1 End If If ExitDialog1 Then DisplayIt = 0 Else DisplayIt = 1 End If End Function '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Function getFile() Dim obj As Object Set obj = Client.CommonDialogs getFile = obj.FileExplorer() Set obj = Nothing End Function '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Function GetUsername(sTempFile As String) As String Dim connStr As String Dim objConn As Object Dim rs As Object Dim eqn As String Dim sTempUsername As String connStr = "PROVIDER=Microsoft.SQLSERVER.CE.OLEDB.3.5; Data Source=" & WorkingDirectory & "ProjectOverview.sdf" eqn = "SELECT * " eqn = eqn & " FROM Overview " Set objConn = CreateObject("ADODB.Connection") objConn.open connStr Set rs = objConn.execute(eqn) Do While Not rs.EOF If rs.Fields("Filename") = "Join Databases1.IMD" And rs.Fields("TaskType") <> 6 Then sTempUsername = rs.Fields("UserName") Exit Do End If rs.MoveNext Loop Set rs = Nothing Set objConn = Nothing GetUsername = sTempUsername End Function '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Function validateMenu1() As Boolean validateMenu1 = TRUE If DatabaseName = "" Then MsgBox "Select a database", MB_ICONEXCLAMATION validateMenu1 = FALSE End If If NewDatabaseName = "" Then MsgBox "Define a new result name", MB_ICONEXCLAMATION validateMenu1 = FALSE End If If checkForSpecialChar(NewDatabaseName, "\/:*?""<>[]|") Then MsgBox "Do not use the following in the result name: - \/:*?""<>[]|", MB_ICONEXCLAMATION validateMenu1 = FALSE End If End Function '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Function checkForSpecialChar(temp_string As String, temp_list As String) As Boolean 'Function to check for special symbols in text. Dim strLen As Integer Dim tempChar As String Dim i As Integer Dim pos As Integer checkForSpecialChar = FALSE strlen = Len(temp_list) For i = 1 To strLen tempChar = Mid(temp_list, i, 1) pos = InStr(1, temp_string, tempChar) If pos > 0 Then checkForSpecialChar = TRUE End If Next i End Function '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- 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 '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Function GetFieldsList1() Dim fields As Integer Dim source As database Dim table As table Dim field As field Dim rst As Object Dim i As Integer Dim j As Integer Dim k As Integer Dim l As Integer Set source=client.opendatabase(DatabaseName) Set table=source.tabledef Set rst =source.recordset fields=table.count ReDim FieldList1$(fields) j=1 For i=1 To fields Set field=table.getfieldat(i) 'If field.Isnumeric Then FieldList1$(j)=field.name j=j+1 'End If Next i End Function '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Function Summarization1 Dim db As database Dim task As task Dim dbName As String Dim i As Integer Set db = Client.OpenDatabase(DatabaseName) Set task = db.Summarization task.AddFieldToSummarize SelectedField1 dbName = "Temp.IMD" task.OutputDBName = dbName task.CreatePercentField = FALSE task.PerformTask Set task = Nothing Set db = Nothing End Function '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Function ExportDatabase1 Dim db As database Dim task As task Dim eqn As String Dim dbName As String Set db = Client.OpenDatabase("Temp.IMD") Set task = db.ExportDatabase task.AddFieldToInc SelectedField1 task.Separators "~", "," task.PerformTask WorkingDirectory & "\Exports.ILB" & "\Temp1.DEL", "Database", "DEL", 1, db.Count, eqn Set db = Nothing Set task = Nothing End Function '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Function DeleteDatabase1 Client.DeleteDatabase "Temp.IMD" End Function '-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Function ImportText1 Const fsoForReading = 1 Dim objFSO Dim objTextStream Dim FirstTime As Boolean Dim FileName As String Dim i As Integer FileName = WorkingDirectory & "\Exports.ILB" & "\Temp1.DEL" FirstTime = True Set objFSO = CreateObject("Scripting.FileSystemObject") Set objTextStream = objFSO.OpenTextFile(FileName, fsoForReading) Do Until objTextStream.AtEndOfStream If FirstTime Then FirstTime = False ReDim DataList1$(0) Dim TempText (0) As String DataList1$(0) = objTextStream.ReadLine Else ReDim preserve DataList1$(UBound(DataList1$) + 1) DataList1$(UBound(DataList1$)) = objTextStream.ReadLine End If Loop Set objTextStream = Nothing Set objFSO = Nothing DlgListBoxArray "ShowSampleRecord", DataList1$() Kill WorkingDirectory & "\Exports.ILB" & "\Temp1.DEL" Dim TempArray1$() ReDim TempArray1$(UBound(DataList1$)) For i = 0 To UBound(DataList1$) TempArray1$(i) = Left(DataList1$(i), Len(DataList1$(i)) - 1) Next i Dim TempArray2$() ReDim TempArray2$(UBound(TempArray1$)) For i = 0 To UBound(TempArray1$) TempArray2$(i) = Right(TempArray1$(i), Len(TempArray1$(i)) - 1) Next i ReDim DataList2$(UBound(TempArray2$)) For i = 0 To UBound(TempArray2$) DataList2$(i) = TempArray2$(i) Next i DlgListBoxArray "Show2", DataList2$() End Function '--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------