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