openaccess/source/modules/optimizer.bas

Option Compare Database
Option Explicit

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

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 " & typefilter(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 rs![dateupdate] > 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_sources_date = CDate(vcs_param("sources_date", "01/01/1900 00:00:00"))

End Function

Public Sub update_sources_date()

If Not vcs_tbl_exists() Then
    Call create_vcs_tbl
End If

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 (typefilter(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


Public Sub CleanObjects()




End Sub

'*** utilities
Private Function typefilter(acType) As String
'returns a sql filter string for the object type
'NB: types in msysobjects table
'-32768 = Form
'-32766 = Macro
'-32764 = Report
'-32761 = Module
'-32758  Users
'-32757  Database Document
'-32756  Data Access Pages
'1   Table - Local Access Tables
'2   Access Object - Database
'3   Access Object - Containers
'4   Table - Linked ODBC Tables
'5   Queries
'6   Table - Linked Access Tables
'8   SubDataSheets

    Select Case acType
        Case acTable
            typefilter = "([Type]=1 or [Type]=4 or [Type]=6)"
        Case acQuery
            typefilter = "[Type]=5"
        Case acForm
            typefilter = "[Type]=-32768"
        Case acReport
            typefilter = "[Type]=-32764"
        Case acModule
            typefilter = "[Type]=-32761"
        Case acMacro
            typefilter = "[Type]=-32766"
        Case Else
            GoTo typerror
    End Select

Exit Function
typerror:
    MsgBox "typerror:" & acType & " is not a valid object type"
    typefilter = ""
End Function



Public Function remove_ext(ByVal filename As String) As String
    ' removes the extension of a file name
    If Not InStr(filename, ".") > 0 Then
        remove_ext = filename
        Exit Function
    End If

    Dim splitted_name As Variant
    splitted_name = Split(filename, ".")

    Dim i As Integer
    remove_ext = ""
    For i = 0 To (UBound(Split(filename, ".")) - 1)
        If Len(remove_ext) > 0 Then remove_ext = remove_ext & "."
        remove_ext = remove_ext & Split(filename, ".")(i)
    Next i

End Function