openaccess/source/modules/VCS_Optimizer.bas

Option Compare Database
Option Explicit

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

' *** activates the optimizer
Private p_optimizer As Boolean

Public Sub activate_optimizer()
    p_optimizer = True
End Sub

Public Function optimizer_activated()
    optimizer_activated = p_optimizer
End Function
'***


'*** main methods
Public Function is_dirty(acType As Integer, name As String)
' has the object been modified since last export?

    is_dirty = (get_last_update_date(acType, name) > get_sources_date)

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_modified(acType As Integer)
' returns a list (string with ';' separator) of the objects wich were updated since last export
    Dim sources_date As Date
    
    list_modified = ""
    
    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 Then
                If Len(list_modified) > 0 Then
                    list_modified = list_modified & ";" & rs![name]
                Else
                    list_modified = rs![name]
                End If
            End If
            
        End If
        rs.MoveNext
    Loop

    Exit Function
emptylist:
End Function

Public Function msg_list_modified() 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_modified = ""

    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_modified(CInt(obj_type_num))
        
        If Len(lstmod) > 0 Then
            msg_list_modified = msg_list_modified & "** " & UCase(obj_type_label) & " **" & vbNewLine
            For Each objname In Split(lstmod, ";")
                msg_list_modified = msg_list_modified & "   - " & objname & vbNewLine
            Next objname
        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(vcs_param("sources_date", "01/01/1900 00:00:00"))

End Function

Public Sub update_sources_date()
    ' update the sources date with Now()
    
    Call update_vcs_param("sources_date", CStr(Now))

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\"
    
    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
                End If
            End If
            
        Next file
next_obj_type:
    Next obj_type


End Function