Option Compare Database Option Explicit '**** '* '* Optimizer for Open Access: only import/export objects which were updated since last import/export '* '**** ' *** activates the optimizer Private p_optimizer As Boolean 'needs_export Public Const NoExportNeeded = 0 Public Const MissingFiles = 1 Public Const UpdateNeeded = 2 Public Sub activate_optimizer() p_optimizer = True End Sub Public Function optimizer_activated() optimizer_activated = p_optimizer End Function '*** '*** main methods Public Function needs_export(acType As Integer, name As String) As Integer ' a file needs to be export if it has been updated since last export, or if its source files are missing ' returns an integer (see constants) If Not files_exist_for(acType, name) Then needs_export = MissingFiles ElseIf get_last_update_date(acType, name) > get_sources_date() Then needs_export = UpdateNeeded Else needs_export = NoExportNeeded End If End Function Public Function get_last_update_date(ByVal acType As Integer, ByVal name As String) On Error GoTo err 'get the date of the last update of an object Select Case acType 'case table or query: get [DateUpdate] in MSysObjects Case acTable get_last_update_date = DFirst("DateUpdate", "MSysObjects", "([Type]=1 or [Type]=4 or [Type]=6) and [name]='" & name & "'") Case acQuery get_last_update_date = DFirst("DateUpdate", "MSysObjects", "[Type]=5 and [name]='" & name & "'") 'MSysObjects is not reliable for other objects, 'So we used the DateModified property: Case acForm get_last_update_date = CurrentProject.AllForms(name).DateModified Case acReport get_last_update_date = CurrentProject.AllReports(name).DateModified Case acMacro get_last_update_date = CurrentProject.AllMacros(name).DateModified Case acModule get_last_update_date = CurrentProject.AllModules(name).DateModified End Select Exit Function err: Debug.Print "get_last_update_date - erreur - " & acType & ", " & name & ": " & err.Description get_last_update_date = #1/1/1900# End Function '*** displays modified (dirties) objects Public Function list_to_export(acType As Integer) ' returns a list (string with ';' separator) of the objects wich will be exported Dim sources_date As Date list_to_export = "" sources_date = get_sources_date() Dim rs As DAO.Recordset Set rs = CurrentDb.OpenRecordset("SELECT * FROM MSysObjects WHERE " & msys_type_filter(acType) & ";", _ dbOpenSnapshot) If rs.RecordCount = 0 Then GoTo emptylist rs.MoveFirst Do Until rs.EOF If Left$(rs![name], 4) <> "MSys" And _ Left$(rs![name], 1) <> "~" Then If get_last_update_date(acType, rs![name]) > sources_date Or _ Not files_exist_for(acType, rs![name]) Then If Len(list_to_export) > 0 Then list_to_export = list_to_export & ";" & rs![name] Else list_to_export = rs![name] End If End If End If rs.MoveNext Loop Exit Function emptylist: End Function Public Function msg_list_to_export() As String 'returns a formatted text listing all of the objects which were updated since last export of the sources Dim lstmod, obj_type_split, obj_type_label, obj_type_num As String Dim obj_type, objname As Variant msg_list_to_export = "" For Each obj_type In Split( _ "tables|" & acTable & "," & _ "queries|" & acQuery & "," & _ "forms|" & acForm & "," & _ "reports|" & acReport & "," & _ "macros|" & acMacro & "," & _ "modules|" & acModule _ , "," _ ) obj_type_split = Split(obj_type, "|") obj_type_label = obj_type_split(0) obj_type_num = obj_type_split(1) lstmod = list_to_export(CInt(obj_type_num)) If Len(lstmod) > 0 Then msg_list_to_export = msg_list_to_export & "> " & UCase(obj_type_label) & ":" & vbNewLine For Each objname In Split(lstmod, ";") msg_list_to_export = msg_list_to_export & objname msg_list_to_export = msg_list_to_export & ", " Next objname msg_list_to_export = Left(msg_list_to_export, Len(msg_list_to_export) - 2) & vbNewLine & vbNewLine End If Next obj_type End Function '****** '*** sources_date is the date of the last export of the sources files Public Function get_sources_date() As Date ' get the registered sources date get_sources_date = CDate(oa_param("sources_date", "01/01/1900 00:00:00")) End Function Public Sub update_sources_date() ' update the sources date with Now() Dim new_val As String new_val = CStr(Now) Call update_oa_param("sources_date", CStr(Now)) logger "update_sources_date", "DEBUG", "Source's date updated to " & new_val End Sub '***** '**** cleans sources or objects after differential import/export Public Function CleanDirs(Optional ByVal sim As Boolean = False) ' cleans the directories after a differential export ' returns a list of the deleted relative file paths (string with '|' separator) ' if 'sim' is set to True, doesn't process to the delete but still return the list CleanDirs = "" Dim source_path As String source_path = VCS_Dir.ProjectPath() & "source\" logger "CleanDirs", "INFO", "Optimizer ON: cleans the directories from " & source_path Dim rsSys As DAO.Recordset Dim sql As String sql = "SELECT name, type FROM MSysObjects;" Set rsSys = CurrentDb.OpenRecordset(sql, dbOpenSnapshot) Dim subdir, filename, objectname, obj_type_label As String Dim obj_type, obj_type_split As Variant Dim obj_type_num As Integer Dim oFSO As Scripting.FileSystemObject Dim oFld As Scripting.Folder Dim file As Scripting.file 'Instanciation du FSO Set oFSO = New Scripting.FileSystemObject For Each obj_type In Split( _ "forms|" & acForm & "," & _ "reports|" & acReport & "," & _ "macros|" & acMacro & "," & _ "modules|" & acModule _ , "," _ ) obj_type_split = Split(obj_type, "|") obj_type_label = obj_type_split(0) obj_type_num = obj_type_split(1) subdir = source_path & obj_type_label If Not oFSO.FolderExists(subdir) Then GoTo next_obj_type Set oFld = oFSO.GetFolder(subdir) For Each file In oFld.Files objectname = remove_ext(file.name) rsSys.FindFirst (msys_type_filter(obj_type_num) & " AND [name]='" & objectname & "'") If rsSys.NoMatch Then 'object doesn't exist anymore If Len(CleanDirs) > 0 Then CleanDirs = CleanDirs & "|" CleanDirs = CleanDirs & (Replace(file.path, CurrentProject.path, ".")) If Not sim Then oFSO.DeleteFile file logger "CleanDirs", "DEBUG", "> removed: " & file End If End If Next file next_obj_type: Next obj_type End Function Public Function files_exist_for(acType As Integer, name As String) As Boolean 'does the object has its files in sources Dim source_path As String source_path = VCS_Dir.ProjectPath() & "source\" Select Case acType Case acForm files_exist_for = (dir(source_path & "forms\" & name & ".bas") <> "") Case acReport files_exist_for = (dir(source_path & "reports\" & name & ".bas") <> "" _ And _ dir(source_path & "reports\" & name & ".pv") <> "") Case acQuery files_exist_for = (dir(source_path & "queries\" & name & ".bas") <> "") Case acTable files_exist_for = ( _ dir(source_path & "tbldef\" & name & ".sql") <> "" _ Or _ dir(source_path & "tbldef\" & name & ".lnkd") <> "" _ ) Case acMacro files_exist_for = (dir(source_path & "macros\" & name & ".bas") <> "") Case acModule files_exist_for = (dir(source_path & "modules\" & name & ".bas") <> "") End Select End Function