openaccess/source/modules/OA_Optimizer.bas

Option Compare Database
Option Private Module
Option Explicit

'****
'*
'* Optimizer for Open Access: only import/export objects which were updated since last import/export
'*
'****

'needs_export
Public Const NoExportNeeded = 0
Public Const MissingFiles = 1
Public Const UpdateNeeded = 2

'***


'*** 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]=" & Chr(34) & name & Chr(34) & "")
        Case acQuery
            get_last_update_date = DFirst("DateUpdate", "MSysObjects", "[Type]=5 and [name]=" & Chr(34) & name & Chr(34) & "")
        
        '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 _
            Not rs![name] Like "f_*_data" 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(ByVal newer_only As Boolean) 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)

        msg_list_to_export = msg_list_to_export & "> " & UCase(obj_type_label) & ":  "

        If newer_only = False Then
    
            msg_list_to_export = msg_list_to_export & "(All)"
        
        Else
            
            lstmod = list_to_export(CInt(obj_type_num))
            
            If Len(lstmod) > 0 Then
                Dim count, total As Integer
                count = UBound(Split(lstmod, ";")) + 1
                total = DCount("name", "MSysObjects", "[name] not like 'MSys*' and [name] not like '~*' and " & msys_type_filter(obj_type_num))
                
                If count = total Then
                    
                    msg_list_to_export = msg_list_to_export & "(All)"
                
                Else
                
                    If count < 12 Then
                        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)
                    Else
                        msg_list_to_export = msg_list_to_export & CStr(count) & " on " & CStr(total)
                    End If
                    
                End If
            Else
            
                msg_list_to_export = msg_list_to_export & "(None)"
                
            End If
            
        End If
        
        msg_list_to_export = msg_list_to_export & vbNewLine
        
    Next obj_type

    Dim include_tables As String
    
    include_tables = get_include_tables()
    If UBound(Split(include_tables, ",")) < 5 Then
        msg_list_to_export = msg_list_to_export & "> DATA: " & include_tables & vbNewLine
    Else
        msg_list_to_export = msg_list_to_export & "> DATA: (more than 5)" & vbNewLine
    End If
    
    msg_list_to_export = msg_list_to_export & "> RELATIONS" & vbNewLine & "> REFERENCES" & vbNewLine & "> DB PROPERTIES"
    
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 = source_dir()
    
    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, dirname, short_path 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( _
        "tables|" & acTable & "," & _
        "tbldef|" & acTable & "," & _
        "queries|" & acQuery & "," & _
        "forms|" & acForm & "," & _
        "reports|" & acReport & "," & _
        "macros|" & acMacro & "," & _
        "modules|" & acModule _
        , "," _
    )
    
        obj_type_split = Split(obj_type, "|")
        dirname = obj_type_split(0)
        obj_type_num = obj_type_split(1)
        
        subdir = source_path & dirname
        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)
            objectname = to_accessname(objectname)
            
            If InStr("[34]", objectname) > 0 Then
                logger "CleanDirs", "DEBUG", "> " & short_path & " ignored because of [64] (double quotes)"
                GoTo next_file
            End If
            
            rsSys.FindFirst (msys_type_filter(obj_type_num) & " AND [name]=" & Chr(34) & objectname & Chr(34) & "")
            
            If rsSys.NoMatch Then
                'object doesn't exist anymore
                If Len(CleanDirs) > 0 Then CleanDirs = CleanDirs & "|"
                short_path = Replace(file.path, CurrentProject.path, ".")
                CleanDirs = CleanDirs & short_path
                
                If Not sim Then
                    oFSO.DeleteFile file
                    logger "CleanDirs", "DEBUG", "> removed: " & short_path
                End If
            End If
next_file:
        Next file
        
        
next_obj_type:
    Next obj_type
    
    logger "CleanDirs", "INFO", "> Cleaned: " & CleanDirs

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 = source_dir()
    
    name = to_filename(name)
    
    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 & "tbldefs\" & name & ".xml") <> "" _
                                 Or _
                                 dir(source_path & "tbldefs\" & name & ".lnkd") <> "" _
                               )
        
        Case acMacro
            files_exist_for = (dir(source_path & "scripts\" & name & ".bas") <> "")
        
        Case acModule
            files_exist_for = (dir(source_path & "modules\" & name & ".bas") <> "")
    
    End Select


End Function

Public Function CleanApp(Optional ByVal sim As Boolean = False) As String
' 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
    On Error GoTo err
    Dim subdir, filename, objectname, dirname, short_path As String
    Dim obj_type, obj_type_split As Variant
    Dim obj_type_num As Integer
    Dim acType As Integer
    
    CleanApp = ""
    
    logger "CleanApp", "INFO", "Cleans the application objects"
    
    Dim rsSys As DAO.Recordset
    Dim sql As String
    
    sql = "SELECT name, type FROM MSysObjects WHERE " & _
          "(name not like '~*' and name not like 'MSys*' and name not like 'f_*_Data' and name <> 'USysOpenAccess');"
    Set rsSys = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)
    
    On Error GoTo next_record
    
    rsSys.MoveFirst
    Do Until rsSys.EOF = True
        
        Select Case rsSys![Type]
            Case -32768 'form
                acType = acForm
            Case -32766 'macro
                acType = acMacro
            Case -32764 'report
                acType = acReport
            Case 32761 'module
                acType = acModule
            Case 1 'local table
                acType = acTable
            Case 4  'linked table
                acType = acTable
            Case 5  'queries
                acType = acQuery
            Case Else
                GoTo next_record
        End Select
        
        If Not files_exist_for(acType, rsSys![name]) Then
            If sim = False Then
                logger "CleanApp", "DEBUG", "> remove: " & rsSys![name] & " (" & acType & ")"
                DoCmd.DeleteObject acType, rsSys![name]
            End If
            
            If Len(CleanApp) > 0 Then CleanApp = CleanApp & "|"
            CleanApp = CleanApp & rsSys![name]
    
        End If
next_record:
        If err.Number > 0 Then
            logger "CleanApp", "ERROR", "Unable to delete " & rsSys![name] & " (" & acType & "): " & err.Description
            err.Clear
            On Error GoTo next_record
        End If
        rsSys.MoveNext
        
    Loop
    
    On Error GoTo err
    logger "CleanApp", "INFO", "> Cleaned: " & CleanApp

Exit Function
err:
    logger "CleanApp", "ERROR", err.Description
End Function