Dim listbox3$() AS string Begin Dialog dlgProjectOverview 0,20,407,185,"ProjectOverview.sdf Analyzer", .DisplayIt OKButton 31,97,67,41, "OK", .OKButton1 CancelButton 121,98,70,39, "Cancel", .CancelButton1 PushButton 13,34,100,28, "Project Overview SDF File Select", .PushButton3 Text 119,37,241,17, "Text", .sdfFilename End Dialog Begin Dialog dlgSelectFile 0,40,392,161,"Select File", .NewDialog ListBox 14,20,327,85, listbox3$(), .ListBox1 OKButton 20,111,64,23, "OK", .OKButton1 CancelButton 115,112,60,23, "Cancel", .CancelButton1 Text 40,5,101,13, "Select the sdf file", .Text1 End Dialog '*********************************************************************************************** '* Author: Scott Winkel (Calgary TSO) '* 587-475-3730 '* Script: ProjectOverview Analyzer '* Date: March 28, 2018 '* Purpose: Analyze contents of ProjectOverview.sdf (idea history) file and create IDEA database with contents. '* Contact me for issues or suggestions for improvement '************************************************************************************************* Option Explicit 'create a type to hold the entire overview table from the database Type project TaskName As String DateTime As String UserName As String IDEAScript As String HistoryLog As String DataBaseGUID As String TaskGUID As String Filename As String SubFolder As String ProjectName As String End Type Public files() Dim working_directory As String Dim exit_script As Boolean Dim folder As String Dim searchFile As String Dim db As Object Dim ideaScriptstr As String Dim UniqueName As String Dim UniqueName1 As String Dim IDEAHistoryTable As Object Sub Main() working_directory = client.WorkingDirectory() Call menu If exit_script Then GoTo end_sub end_sub: client.RefreshFileExplorer End Sub Function menu() Dim dlg As dlgProjectOverview Dim dlgSelect As dlgSelectFile Dim button, continue, button2 As Integer Dim x, z As Integer folder = "" main_menu: button = Dialog(dlg) Select Case button Case -1 'hit ok button If searchFile = "" Then MsgBox "Please select a ProjectOverview.sdf file.", MB_ICONEXCLAMATION, "No File Selected" GoTo main_menu End If Case 0 'cancel button exit_script = True GoTo end_function Case 1 'obtain the sdf continue = MsgBox("Is the sdf file located in your IDEA working directory?", 4 + 32, "sdf location") If continue = IDYES Then folder = client.WorkingDirectory 'working_directory Else folder = getFolder() End If If folder = "" Then GoTo main_menu End If ReDim listbox3$(0) If (FindFiles(folder, "sdf", files) = True) Then x = UBound(files) ReDim listbox3$(x) For z = 0 To x listbox3$(z) = files(z) Next End If button2 = Dialog(dlgSelect) If button2 = -1 Then searchFile = listbox3$(dlgSelect.ListBox1) searchFile = folder + searchFile Else GoTo main_menu End If 'conect to sdf file If searchFile <> "" Then If client.WorkingDirectory <> folder Then client.WorkingDirectory = folder End If Call createIDEAdb Call connectSDB End If End Select end_function: End Function Function createIDEAdb() Dim NewField As Object ' Create a table. Set IDEAHistoryTable = client.NewTableDef ' Define a field for the table. Set NewField = IDEAHistoryTable.NewField NewField.Name = "DATETIME" NewField.Type = WI_CHAR_FIELD NewField.Length = 30 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "DATE" NewField.Type = WI_EDIT_DATE NewField.Equation = "@Ctod(""20100101"", ""YYYYMMDD"")" IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "TIME" NewField.Type = WI_EDIT_TIME NewField.Equation = "@Ctot(""00:01:01"", ""hh:mm:ss"")" IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "FILENAME" NewField.Type = WI_CHAR_FIELD NewField.Length = 100 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "FILENAME_GUID" NewField.Type = WI_CHAR_FIELD NewField.Length = 40 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "TASKNAME" NewField.Type = WI_CHAR_FIELD NewField.Length = 75 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "TASKNAME_GUID" NewField.Type = WI_CHAR_FIELD NewField.Length = 40 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "IDEASCRIPT" NewField.Type = WI_CHAR_FIELD NewField.Length = 1000 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "IDEASCRIPT_1" NewField.Type = WI_CHAR_FIELD NewField.Length = 1000 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "IDEASCRIPT_2" NewField.Type = WI_CHAR_FIELD NewField.Length = 1000 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "IDEASCRIPT_3" NewField.Type = WI_CHAR_FIELD NewField.Length = 1000 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "HISTORY_LOG" NewField.Type = WI_CHAR_FIELD NewField.Length = 1000 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "HISTORY_LOG_1" NewField.Type = WI_CHAR_FIELD NewField.Length = 1000 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "USERNAME" NewField.Type = WI_CHAR_FIELD NewField.Length = 20 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "SUBFOLDER" NewField.Type = WI_CHAR_FIELD NewField.Length = 100 IDEAHistoryTable.AppendField NewField Set NewField = IDEAHistoryTable.NewField NewField.Name = "PROJECTNAME" NewField.Type = WI_CHAR_FIELD NewField.Length = 100 IDEAHistoryTable.AppendField NewField Set NewField = Nothing ' Change the table settings to allow writing. IDEAHistoryTable.Protect = False ' Create the database. UniqueName = client.UniqueFileName("ProjectOverview.IMD") Set db = client.NewDatabase(UniqueName, "", IDEAHistoryTable) client.RefreshFileExplorer End Function Function connectSDB() Dim objConn As Object Dim connStr As String Dim rs As Object Dim ProjectInfo() As project Dim bFirstTime As Boolean Dim a, p As Long Dim rec As Object Dim table As Object Dim field As Object Dim task As Object Dim dbName As String bFirstTime = True ReDim ProjectInfo(0) p = 0 'create the connection object to the database Set objConn = CreateObject("ADODB.Connection") 'create the connection string. The Data source has to point to the sdf file of the project you want to extract the info connStr = "Provider=Microsoft.SQLSERVER.CE.OLEDB.3.5;Data Source=" & searchFile & ";""" 'connect to the database objConn.Open connStr 'use SQL to access the information. In this instance all the fields are accessed, I used the field names instead of using SELECT *.* Set rs = objConn.Execute("SELECT DateTime, Filename, DatabaseGUID, TaskName, TaskGUID, IDEAScript, HistoryLog, UserName, SubFolder, ProjectName FROM Overview") ' 'loop through the table Do While Not rs.EOF 'increment the array to hold the informaiton If Not bFirstTime Then ReDim Preserve ProjectInfo(UBound(ProjectInfo) + 1) End If 'populate the array with the information. ProjectInfo(p).DateTime = rs.Fields("DateTime") ProjectInfo(p).Filename = rs.Fields("Filename") ProjectInfo(p).DataBaseGUID = rs.Fields("DatabaseGUID") ProjectInfo(p).TaskName = rs.Fields("TaskName") ProjectInfo(p).TaskGUID = rs.Fields("TaskGUID") ProjectInfo(p).IDEAScript = rs.Fields("IDEAScript") ProjectInfo(p).HistoryLog = rs.Fields("HistoryLog") ProjectInfo(p).UserName = rs.Fields("UserName") ProjectInfo(p).SubFolder = rs.Fields("SubFolder") ProjectInfo(p).ProjectName = rs.Fields("ProjectName") p = p + 1 'move to the next record. rs.MoveNext bFirstTime = False Loop For a = 0 To p - 1 ' Obtain the recordset. Set db = client.OpenDatabase(UniqueName) Set rs = db.Recordset ' Obtain a new record. If ProjectInfo(a).TaskName <> "Delete Database" And iisini("idea history", ProjectInfo(a).Filename) = 0 And iisini("projectoverview", ProjectInfo(a).Filename) = 0 Then Set rec = rs.NewRecord rec.SetCharValue "DateTime", ProjectInfo(a).DateTime rec.SetDateValue "Date", Format$(ProjectInfo(a).DateTime, "YYYYMMDD") rec.SetCharValue "TIME", Format$(ProjectInfo(a).DateTime, "hh:mm:ss") rec.SetCharValue "Filename", ProjectInfo(a).Filename rec.SetCharValue "FILENAME_GUID", ProjectInfo(a).DataBaseGUID rec.SetCharValue "TaskName", ProjectInfo(a).TaskName rec.SetCharValue "TASKNAME_GUID", ProjectInfo(a).TaskGUID ideaScriptstr = ProjectInfo(a).IDEAScript normalizeStrLF (ideaScriptstr) normalizeStr (ideaScriptstr) ideaScriptstr = "'" & isplit(ideaScriptstr, "", "", 1, 0) & Chr(13) & Chr(10) & "Function " & isplit(ideaScriptstr, "", "", 1, 0) & Chr(13) & Chr(10) & Chr(9) & isplit(ideaScriptstr, "", "", 1, 0) & Chr(13) & Chr(10) & "End Function" & Chr(13) & Chr(10) normalizeStr1 (ideaScriptstr) rec.SetCharValue "IDEAScript", Left(ideaScriptstr, 1000) If Len(ideaScriptstr) > 1000 Then rec.SetCharValue "IDEAScript_1", Mid(ideaScriptstr, 1001, 2000) End If If Len(ideaScriptstr) > 2000 Then rec.SetCharValue "IDEAScript_2", Mid(ideaScriptstr, 2001, 3000) End If If Len(ideaScriptstr) > 3000 Then rec.SetCharValue "IDEAScript_3", Mid(ideaScriptstr, 3001, 4000) End If rec.SetCharValue "History_Log", Left(ProjectInfo(a).HistoryLog, 1000) If Len(ProjectInfo(a).HistoryLog) > 1000 Then rec.SetCharValue "History_Log_1", Mid(ProjectInfo(a).HistoryLog, 1001, 2000) End If rec.SetCharValue "UserName", ProjectInfo(a).UserName rec.SetCharValue "SubFolder", ProjectInfo(a).SubFolder rec.SetCharValue "ProjectName", ProjectInfo(a).ProjectName rs.AppendRecord rec End If Next a Set IDEAHistoryTable = db.tabledef IDEAHistoryTable.Protect = True Set db = Nothing Set IDEAHistoryTable = Nothing Set rec = Nothing Set rs = Nothing Set objConn = Nothing Set table = Nothing Set field = Nothing Set task = Nothing client.CloseAll 'Remove blank fields below Dim MyRecordset As Recordset Dim FirstRecChar, CurrentRecordValueChar As String Dim j, s As Long Dim MyRecord As Record Dim MyFieldName As String Set db = client.OpenDatabase(UniqueName) Set table = db.tabledef Set MyRecordset = db.Recordset FirstRecChar = "" CurrentRecordValueChar = "" Dim miscField(5) As String miscField(0) = "IDEASCRIPT_1" miscField(1) = "IDEASCRIPT_2" miscField(2) = "IDEASCRIPT_3" miscField(3) = "History_Log_1" miscField(4) = "SUBFOLDER" miscField(5) = "PROJECTNAME" For s = 0 To 5 Set field = table.getfield(miscField(s)) 'If field.IsCharacter() = TRUE Then MyRecordset.getat (1) Set MyRecord = MyRecordset.activerecord FirstRecChar = MyRecord.GetCharValue(miscField(s)) For j = 2 To db.Count MyRecordset.getat (j) Set MyRecord = MyRecordset.activerecord MyFieldName = field.Name CurrentRecordValueChar = MyRecord.GetCharValue(miscField(s)) If CurrentRecordValueChar <> FirstRecChar Then j = db.Count Else If j = db.Count Then Set task = db.TableManagement task.RemoveField miscField(s) task.PerformTask Set task = Nothing End If End If Next j Next s Set MyRecordset = Nothing Set MyRecord = Nothing Set db = Nothing Set table = Nothing Set field = Nothing 'End Remove blank fields 'Below summarization is done to remove duplicate tasks. 'It is assumed if the same task was done on the same filename it was redone at a later date to produce the final file/version. So last occurence of filename and task is used. Set db = client.OpenDatabase(UniqueName) Set task = db.Summarization task.AddFieldToSummarize "FILENAME" task.AddFieldToSummarize "IDEASCRIPT" 'task.AddFieldToSummarize "IDEASCRIPT_1" task.IncludeAllFields UniqueName1 = client.UniqueFileName("ProjectOverview Summariztion.IMD") task.OutputDBName = UniqueName1 task.CreatePercentField = False task.UseFieldFromFirstOccurrence = False task.PerformTask Set task = Nothing Set db = Nothing client.CloseAll client.DeleteDatabase UniqueName On Error Resume Next Set db = client.OpenDatabase(UniqueName1) Set task = db.Extraction task.AddFieldToInc "DATETIME" task.AddFieldToInc "DATE" task.AddFieldToInc "TIME" task.AddFieldToInc "FILENAME" task.AddFieldToInc "FILENAME_GUID" task.AddFieldToInc "TASKNAME" task.AddFieldToInc "TASKNAME_GUID" task.AddFieldToInc "IDEASCRIPT" task.AddFieldToInc "IDEASCRIPT_1" task.AddFieldToInc "IDEASCRIPT_2" task.AddFieldToInc "IDEASCRIPT_3" task.AddFieldToInc "HISTORY_LOG" task.AddFieldToInc "HISTORY_LOG_1" task.AddFieldToInc "USERNAME" task.AddFieldToInc "SUBFOLDER" task.AddFieldToInc "PROJECTNAME" task.AddKey "DATE", "A" task.AddKey "TIME", "A" UniqueName = client.UniqueFileName("ProjectOverview Extraction.IMD") task.AddExtraction UniqueName, "", "" task.CreateVirtualDatabase = False task.PerformTask 1, db.Count Set task = Nothing Set db = Nothing client.CloseAll client.DeleteDatabase UniqueName1 Set db = client.OpenDatabase(UniqueName) Set task = db.TableManagement Set field = db.tabledef.NewField field.Name = "PRECNO" field.Description = "" field.Type = WI_VIRT_NUM field.Equation = "@precno()" field.Decimals = 0 task.AppendField field task.PerformTask Set task = Nothing Set field = Nothing Set task = db.Extraction task.AddFieldToInc "PRECNO" task.AddFieldToInc "DATETIME" task.AddFieldToInc "DATE" task.AddFieldToInc "TIME" task.AddFieldToInc "FILENAME" task.AddFieldToInc "FILENAME_GUID" task.AddFieldToInc "TASKNAME" task.AddFieldToInc "TASKNAME_GUID" task.AddFieldToInc "IDEASCRIPT" task.AddFieldToInc "IDEASCRIPT_1" task.AddFieldToInc "IDEASCRIPT_2" task.AddFieldToInc "IDEASCRIPT_3" task.AddFieldToInc "HISTORY_LOG" task.AddFieldToInc "HISTORY_LOG_1" task.AddFieldToInc "USERNAME" task.AddFieldToInc "SUBFOLDER" task.AddFieldToInc "PROJECTNAME" task.AddKey "DATE", "A" task.AddKey "TIME", "A" UniqueName1 = client.UniqueFileName("ProjectOverview and Idea History Master.IMD") task.AddExtraction UniqueName1, "", "" task.CreateVirtualDatabase = False task.PerformTask 1, db.Count Set task = Nothing Set db = Nothing client.CloseAll client.DeleteDatabase UniqueName Set db = client.OpenDatabase(UniqueName1) Set table = db.tabledef Set field = table.getfield("FILENAME_GUID") field.SetActionFieldForExtraction UniqueName1, "FILENAME_GUID", "", "", "", "", "", "", "" Set table = Nothing Set field = Nothing Set db = Nothing Set db = client.OpenDatabase(UniqueName1) Set task = db.Extraction task.IncludeAllFields task.AddKey "FILENAME_GUID", "A" task.AddKey "DATE", "A" task.AddKey "TIME", "A" UniqueName = client.UniqueFileName("ProjectOverview sort by Database and Time.IMD") task.AddExtraction UniqueName, "", "" task.CreateVirtualDatabase = False task.PerformTask 1, db.Count Set task = Nothing Set db = Nothing client.CloseAll client.RefreshFileExplorer On Error GoTo 0 MsgBox "Script Complete" End Function Function DisplayIt(ControlID$, Action%, SuppValue%) If searchFile = "" Then DlgText "sdfFilename", "No text file selected" Else DlgText "sdfFilename", "File: " & getFileName(searchFile, 0) End If 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 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 FindFiles(path As String, ext As String, files()) Dim ffile As String Dim firstbackspace As String Dim firstbackspacenum As Integer Dim importname As String ffile = Dir$(path & "*." & ext) If Len(ffile) = 0 Then Exit Function '-------- Dir ext = *.ext* fixing by checking length Do firstbackspace = StrReverse(ffile) firstbackspacenum = InStr(1, firstbackspace, ".") importname = Right(ffile, firstbackspacenum - 1) If Len(importname) = Len(ext) Then If Not IsNull(ffile) Then '-------- If one value found return function true and redim array If (FindFiles = False) Then ReDim files(0) FindFiles = True Else ReDim Preserve files(UBound(files) + 1) End If files(UBound(files)) = ffile Else Exit Do End If End If ffile = Dir Loop Until Len(ffile) = 0 End Function Function getFolder() Dim BrowseFolder As String Dim oFolder, oFolderItem Dim oPath, oShell, strPath Set oShell = CreateObject("Shell.Application") Set oFolder = oShell.Namespace(17) 'the 17 indicates that we are looking at the virtual folder that contains everything on the local computer Set oFolderItem = oFolder.Self Set strPath = oFolderItem.path Set oFolder = oShell.BrowseForFolder(0, "Please select the folder where the ProjectOverview.sdf file is located:", 1, strPath) If (Not oFolder Is Nothing) Then Set oFolderItem = oFolder.Self oPath = oFolderItem.path If Right(oPath, 1) <> "\" Then oPath = oPath & "\" End If End If getFolder = oPath End Function Function normalizeStrLF(sTempIdeaScriptStr As String) As String Dim iLen As Integer Dim i As Integer Dim sChar As String Dim sNewFieldName As String iLen = Len(sTempIdeaScriptStr) For i = 1 To iLen sChar = Mid(sTempIdeaScriptStr, i, 1) If (Asc(sChar) = 10) Then sNewFieldName = sNewFieldName & Chr(13) & Chr(10) & Chr(9) Else sNewFieldName = sNewFieldName & sChar End If Next i ideaScriptstr = sNewFieldName End Function Function normalizeStr(sTempIdeaScriptStr As String) As String Dim iLen As Integer Dim i As Integer Dim sChar As String Dim sNewFieldName As String iLen = Len(sTempIdeaScriptStr) For i = 1 To iLen sChar = Mid(sTempIdeaScriptStr, i, 1) If (Asc(sChar) = 34) Then sNewFieldName = sNewFieldName & "~" Else sNewFieldName = sNewFieldName & sChar End If Next i ideaScriptstr = sNewFieldName End Function Function normalizeStr1(sTempIdeaScriptStr As String) As String Dim iLen As Integer Dim i As Integer Dim sChar As String Dim sNewFieldName As String 'sTempIdeaScriptStr = UCase(sTempIdeaScriptStr) iLen = Len(sTempIdeaScriptStr) For i = 1 To iLen sChar = Mid(sTempIdeaScriptStr, i, 1) If (Asc(sChar) = 126) Then sNewFieldName = sNewFieldName & """" Else sNewFieldName = sNewFieldName & sChar End If Next i ideaScriptstr = sNewFieldName End Function