Auto compact a database

[tomk01]

I'm working with a Database that grows as queries are ran. Is there a way to automatically compact and repair the database on a nightly bases?

 

[hymn]

In A2000 and above
tools
options
general
tick compact on close

Hope this helps
Hymn

 

[tomk01]

I'm using Access 97

 

[hymn]

have a look at
faq705-1955

Hope this helps
Hymn

 

[wemeier]

Hymn was only partly right. In Access97 you can't compact the database you're currently in using VBA code. However, you can put VBA code into a database to compact other databases.

I created a function that resides in a database named CompactDatabases.mdb. The coding finds all databases within a specific directory and repairs and compacts them. It also populates a table showing the "before" and "after" size of the databases:

Option Compare Database
Option Explicit

Private Type UserRec
    bMach(1 To 32) As Byte ' 1st 32 bytes hold machine name
    bUser(1 To 32) As Byte ' 2nd 32 bytes hold user name
End Type

Public Function CompactDatabases(ByVal FolderName As String) As Boolean
'   Compact all databases within a given folder.
'   Input:  a folder name
'   Output: nothing
'   Processing:
'   1.  Create a results table recordset
'   2.  Find each database within a folder and, for each one:
'       a.  create a new record in the results table recordset
'       b.  record the file size before being compacted
'       c.  compact the database
'       d.  record the file size after being compacted
'       e.  add the record to the results table recordset
    
    Dim db As Database                  ' current database
    Dim rstResults As Recordset         ' recordset to hold the results
    Dim rstLdb As Recordset             ' Recordset to hold Ldb filenames
    Dim strDatabaseName As String       ' the name of a database in the folder
    Dim strLdbName As String            ' the name of a Ldb in the folder
    Dim intLdbFile As Integer           ' LDB file number
    Dim intLOF As Integer               ' Length of the Ldb file
    Dim intStart As Integer             ' Integer for getting to record offset
    Dim intI As Integer                 ' Interger
    Dim strMachine As String            ' name of machine with the open database
    Dim strPath As String               ' Path to the LDB file
    Dim strX As String                  ' String
    Dim strLogStr As String
    Dim strLogin As String
    Dim strUser As String
    Dim rUser As UserRec
    
'   First, open a recordset to hold the results
    Set db = CurrentDb()
    Set rstResults = db.OpenRecordset("tblCompactResults")
    
'   Next, populate the recordset with the names of every database in the folder
    Echo True, "Gathering databases in folder " & FolderName & "..."
    DoCmd.RepaintObject acDefault
    
    If Right(FolderName, 1) = "\" Then FolderName = Left(FolderName, Len(FolderName) - 1)
    strDatabaseName = Dir(FolderName & "\*.md?")
    While strDatabaseName <> ""
      With rstResults
        Echo True, "Gathering databases in folder " & FolderName & ":  " & strDatabaseName
        DoCmd.RepaintObject acDefault
        .AddNew
        !FolderName = FolderName
        !DatabaseName = strDatabaseName
        !SizeBefore = FileLen(FolderName & "\" & strDatabaseName)
        .Update
      End With
      strDatabaseName = Dir
    Wend

'   Close the results database and reopen a recordset of all databases not yet compacted
    rstResults.Close
    DoEvents
    
    Set rstLdb = db.OpenRecordset("tblLdbNames")
    strLdbName = Dir(FolderName & "\*.ld?")
    While strLdbName <> ""
      With rstLdb
        .AddNew
        !FolderName = FolderName
        !ldbName = strLdbName
        strPath = FolderName & "\" & strLdbName
        intLdbFile = FreeFile
        Open strPath For Binary Access Read Shared As intLdbFile
        intLOF = LOF(intLdbFile)
        Do While Not EOF(intLdbFile)
          Get intLdbFile, , rUser
            With rUser
              intI = 1
              strMachine = ""
              While .bMach(intI) <> 0
                strMachine = strMachine & Chr(.bMach(intI))
                intI = intI + 1
              Wend
              intI = 1
              strUser = ""
              While .bUser(intI) <> 0
                strUser = strUser & Chr(.bUser(intI))
                intI = intI + 1
              Wend
            End With
          If strMachine <> "" Then
            strLogStr = strMachine & " -- " & strUser
            If InStr(strLogin, strLogStr) = 0 Then
              strLogin = strLogin & strLogStr & ";"
            End If
          End If
          intStart = intStart + 64
        Loop
        Close intLdbFile
        If Len(strLogin) > 1 Then
          !logins = Left(strLogin, 250)
        Else
          !logins = " "
        End If
        .Update
      End With
      strLdbName = Dir
    Wend
    rstLdb.Close
      
    Set rstResults = db.OpenRecordset("SELECT * FROM tblCompactResults WHERE CompactTime Is Null;")
    
'   Compact each of the databases found
    Echo True, "Compacting databases in folder " & FolderName & "..."
    If Not rstResults.EOF Then
      rstResults.MoveFirst
      While Not rstResults.EOF
        Echo True, "Compacting databases in folder " & FolderName & ":  " & strDatabaseName
        DoCmd.RepaintObject acDefault
        With rstResults
          .Edit
          !CompactTime = Now()
          !ErrorMessage = CompactDatabase(!FolderName, !DatabaseName)
          !SizeAfter = FileLen(!FolderName & "\" & !DatabaseName)
          .Update
        End With
        DoEvents
        rstResults.MoveNext
      Wend
    End If

'   Close the results database again
    rstResults.Close
    Set db = Nothing
        
    Echo True

End Function

Public Function CompactDatabase(FolderName As String, DatabaseName As String) As Variant
'   Compact a database
'   Input:  FolderName is the name of the folder in which the database resides
'           Databasename is the name of the database to be compacted
'   Output: Was the compact operation successful (yes/no)?
'   Processing:
'       0.  Checks to see if database is open by checking for a LDB.
'           If a LDB is present the database is bypassed for compaction and creates
'               an error message with the name of the user(s) who have it open.
'       1.  Rename the database to be compacted
'       2.  Compact the database into the old database name
'       3.  Delete the original database
    Dim dtmTime As Date
    Dim dblTime As Double
    Dim strCompactFileName As String
    Dim rstLdb As Recordset
    Dim db As Database
    Dim Sqls As String
    
    Set db = CurrentDb()
    Sqls = " SELECT tblLdbNames.FolderName, tblLdbNames.LdbName FROM tblLdbNames "
    Sqls = Sqls & " WHERE (((tblLdbNames.FolderName)='" & FolderName & "') AND "
    Sqls = Sqls & " ((tblLdbNames.LdbName)='" & Left(DatabaseName, (Len(DatabaseName) - 4)) & ".ldb" & "')); "
    
    Set rstLdb = db.OpenRecordset(Sqls)
    If Not rstLdb.EOF Then
      GoTo CompactDatabase_Err3
    End If
    rstLdb.Close
    
'   First, get a temporary file name by using the current time (as hhmmsshh)
    dtmTime = Now()
    dblTime = dtmTime - Fix(dtmTime)
    strCompactFileName = CStr(CLng(dblTime * 1000000))
                
'   First, rename the database to a dummy name
    On Error GoTo CompactDatabase_Err1
    Name FolderName & "\" & DatabaseName As FolderName & "\" & strCompactFileName & ".mdb"
    
'   Next, compact the database back into the original name
    On Error GoTo CompactDatabase_Err2
    DBEngine.RepairDatabase FolderName & "\" & strCompactFileName & ".mdb"
    DBEngine.CompactDatabase FolderName & "\" & strCompactFileName & ".mdb", FolderName & "\" & DatabaseName
    
'   Finally, delete the original database
    On Error GoTo CompactDatabase_Err1
    Kill FolderName & "\" & strCompactFileName & ".mdb"
    
    CompactDatabase = Null
    
CompactDatabase_Exit:
    Exit Function
    
CompactDatabase_Err1:
    Debug.Print Err.Description
    CompactDatabase = Err.Description
    Resume CompactDatabase_Exit
    
CompactDatabase_Err2:
    Debug.Print Err.Description
    Name FolderName & "\" & strCompactFileName & ".mdb" As FolderName & DatabaseName     ' set the database name back to the original
    CompactDatabase = Err.Description
    Resume CompactDatabase_Exit
    
CompactDatabase_Err3:
    Debug.Print FolderName & "\" & rstLdb!ldbName & ".mdb is Open "
    ' FileCopy FolderName & "\" & rstLdb!ldbName, FolderName & "\" & rstLdb!ldbName & ".jmr"
    CompactDatabase = FolderName & "\" & Left(DatabaseName, (Len(DatabaseName) - 4)) & ".mdb is Open "
    rstLdb.Close
    GoTo CompactDatabase_Exit

End Function

I set up an AutoExec macro in the database to use the RunCode action to call the CompactDatabases function and pass it the name of the folder containing the databases to be compacted. I follow the RunCode action with a Quit action to close the database after all the compacts have completed

Then I create a scheduled task to open CompactDatabases every night. Hope this helps you out.

Cruising the Information Superhighway
_{(your mileage may vary)}