Option Compare Database
Public blnRunSilent As Boolean
Private strLogFile As String
Private blnCreateLog As Boolean
Private strBackupFolder As String
Private intLogType As Integer
Public Const LOG_OVERWRITE As Integer = 1
Public Const LOG_APPEND As Integer = 2
Public Const LOG_USEDATE As Integer = 3
Private blnBackupToCurrentDir As Boolean
Private strDbName As String
Private strDestination As String
Private strCompactTemp As String
Private Const strAccessPath As String = """C:\Program Files\OfficeXP\Office10\Msaccess.exe"""
Private fileNum As Integer
Private strOut As String
Private blnLogSeparated As Boolean
Public Function RunMaintenance(Optional strProfile As String)
On Error GoTo Err_RunMaintenance
If IsMissing(strProfile) Or strProfile = "" Then
fSetAccessWindow (0)
strProfile = Command()
blnRunSilent = True
End If
'MsgBox "Profile: " & strProfile
Dim rs As dao.Recordset
Set rs = CurrentDb.OpenRecordset("tblBackupProfiles", dbReadOnly)
rs.FindFirst "ProfileName = '" & strProfile & "'"
If rs.NoMatch Then
If blnRunSilent = False Then
MsgBox "Could not find the specified profile '" & strProfile & "'"
Else
DoCmd.Quit
End If
Exit Function
Else
blnCreateLog = rs!CreateLog
If blnCreateLog Then
If IsNull(rs!LogFile) Then
strLogFile = ReplaceExtension(CurrentDb.Name, ".log")
Else
strLogFile = rs!LogFile
End If
If IsNull(rs!LogType) Then
intLogType = LOG_APPEND
Else
intLogType = rs!LogType
End If
End If
If IsNull(rs!BackupFolder) Then
blnBackupToCurrentDir = True
Else
blnBackupToCurrentDir = False
strBackupFolder = rs!BackupFolder
End If
'MsgBox "Profile :" & strProfile & vbCrLf & _
"Create Log: " & blnCreateLog & vbCrLf & _
"Log File: " & strLogFile & vbCrLf & _
"Log Type: " & intLogType & vbCrLf & _
"Backup To Current Dir: " & blnBackupToCurrentDir & vbCrLf & _
"Backup Folder: " & strBackupFolder
LogMaint "Starting Maintenance Profile: " & strProfile
Dim sqlDatabasesInProfile As String
sqlDatabasesInProfile = "SELECT tblBackupProfileDetails.*, tblDB.FilePath, tblDB.FileName FROM tblBackupProfileDetails INNER JOIN tblDB ON tblBackupProfileDetails.DatabaseID = tblDB.DatabaseID WHERE (((tblBackupProfileDetails.ProfileName)='" & strProfile & "'));"
Set rs = CurrentDb.OpenRecordset(sqlDatabasesInProfile, dbReadOnly)
Dim strDatabases As String
While Not rs.EOF
If rs.BOF Then
rs.MoveFirst
End If
'strDatabases = strDatabases & rs!DatabaseID & ": " & rs!FilePath & rs!FileName & vbCrLf & _
vbTab & "Backup: " & rs!AutoBackup & vbTab & "Compact: " & rs!AutoCompact & vbTab & "Repair: " & rs!AutoRepair & vbTab & "Recompile: " & rs!AutoCompile & vbCrLf
strDbName = rs!FilePath & rs!FileName
If blnBackupToCurrentDir Then
strBackupFolder = rs!FilePath
End If
strDestination = strBackupFolder & ReplaceExtension(rs!FileName, ".bak")
If rs!AutoBackup Then
LogMaint "Backing up " & strDbName
FileCopy strDbName, strDestination
LogMaint "Back up of " & strDbName & " completed!"
End If
strCompactTemp = strBackupFolder & ReplaceExtension(rs!FileName, ".Compacting")
If rs!AutoCompact Then
LogMaint "Compacting " & strDbName
If ifExists(strCompactTemp) Then
Kill strCompactTemp
End If
DBEngine.CompactDatabase strDbName, strCompactTemp
Kill strDbName
FileCopy strCompactTemp, strDbName
Kill strCompactTemp
'MsgBox strDbName & " was compacted."
LogMaint "Compaction of " & strDbName & " was completed!"
End If
If rs!AutoRepair Then
LogMaint "Repairing " & strDbName
ExecuteCmd strAccessPath & " """ & strDbName & """ /repair"
'MsgBox strDbName & " was repaired."
LogMaint strDbName & " was repaired!"
End If
If rs!AutoCompile Then
LogMaint "Recompiling " & strDbName
ExecuteCmd strAccessPath & " """ & strDbName & """ /decompile"
'MsgBox strDbName & " was recompiled."
LogMaint strDbName & " was recompiled."
End If
rs.MoveNext
DoEvents
Wend
'MsgBox strDatabases
End If
If blnRunSilent Then
DoCmd.Quit
End If
Exit_RunMaintenance:
Exit Function
Err_RunMaintenance:
MsgBox Err.Number & ": " & Err.Description
Resume Next
End Function
Private Sub LogMaint(strActivity As String)
If blnCreateLog Then
fileNum = freeFile
strOut = Format(Now, "mm/dd/yyyy hh:nn") & " - " & strActivity
Select Case intLogType
Case LOG_OVERWRITE:
Open strLogFile For Output As fileNum
Case LOG_APPEND:
Open strLogFile For Append As fileNum
If Not blnLogSeparated Then
Write #fileNum, ""
Write #fileNum, "----------------------------------------------------------------------------"
Write #fileNum, ""
blnLogSeparated = True
End If
Case LOG_USEDATE:
strLogFile = Format(Date, "yyyy-mm-dd") & " " & strLogFile
Open strLogFile For Output As fileNum
End Select
Write #fileNum, strOut
Close #fileNum
End If
End Sub
