Just paste this source code into a module called basReindexDatabase and include it in your project.
'----------------------------------------------------------------------
'
' Module Name: basReindexDatabase
' Written By: C&D Programming Corp.
' Create Date: 5/98
' Copyright: Copyright 1998 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
Option Explicit
'
' This subroutine works by taking a database filename (with or without the
' full path name) and performing the following steps:
'
' 1. Determine the path name.
' 2. Determine the filename.
' 3. Erase any existing backup filename
' 4. Erase the temporary filename ($$INDX$$.MDB)
' 5. Try to open the database exclusively. If it fails, exit sub
' 6. Perform the Compact and Reindexing function
' 7. Rename the files so that the compacted file is now the current file
'
Function ReindexDatabase(sDBName As String) As Integer
Dim sDBBackupName As String
Dim sDBCompactName As String
Dim sDBCompactLockName As String
Dim dbRepair As Database
Dim sFilename As String
Dim sPath As String
Dim iPos As Integer
' if no backslash then assume that the database is located in the
' application directory.
If InStr(sDBName, "\") = 0 Then
sPath = App.Path
If Right(sPath, 1) = "\" Then
sPath = Left(sPath, Len(sPath) - 1) ' remove backslash
End If
sFilename = sDBName
Else
' since a complete filename was passed, break it up
' into a path and filename
iPos = Len(sDBName)
Do While Mid$(sDBName, iPos, 1) <> "\"
iPos = iPos - 1
Loop
sPath = Left(sDBName, iPos - 1)
sFilename = Mid$(sDBName, iPos + 1)
End If
' trim off the extension
sFilename = Mid$(sFilename, 1, InStr(sFilename, ".") - 1)
sDBBackupName = sPath & "\" & sFilename & ".BAK"
sDBCompactName = sPath & "\$$INDX$$.MDB"
sDBCompactLockName = sPath & "\$$INDX$$.LDB"
On Error Resume Next
Screen.MousePointer = vbHourglass
'
' remove the backup file and the temporary file.
'
Kill sDBBackupName
If Err <> 0 And Err <> 53 Then ' 53 = file not found
MsgBox "Error deleting backup file. " & vbCr & "Error code [" & Err.Number & "]" & _
vbCr & "Error Msg: " & Err.Description, vbOKOnly
Screen.MousePointer = vbDefault
Exit Function
End If
Kill sDBCompactName
If Err <> 0 And Err <> 53 Then ' 53 = file not found
MsgBox "Error deleting compact file. " & vbCr & "Error code [" & Err.Number & "]" & _
vbCr & "Error Msg: " & Err.Description, vbOKOnly
Screen.MousePointer = vbDefault
Exit Function
End If
'
' Check to see if the database can be repaired by opening
' the database exclusively
'
ReindexDatabase = False
On Error Resume Next
Set dbRepair = OpenDatabase(sDBName, True, False)
If Err Then
MsgBox "Can not open database exclusively, please make sure nobody else is using " & _
"this software before you reindex the database. The database might also be " & _
"marked readonly." & vbCr & vbCr & _
"Error: " & Err.Description, vbOKOnly
Screen.MousePointer = vbDefault
Exit Function
End If
dbRepair.Close
'
' Perform the database compaction/reindexing
'
CompactDatabase sDBName, sDBCompactName
If Err Then
MsgBox "Error Reindexing database. " & vbCr & "Error code [" & Err.Number & "]" & _
vbCr & "Error Msg: " & Err.Description, vbOKOnly
Kill sDBCompactName
Screen.MousePointer = vbDefault
Exit Function
End If
' rename the current database to the backup database name
' rename the compacted database to the original name
' remove the compacted lock name ($$INDX$$.LDB)
Name sDBName As sDBBackupName
Name sDBCompactName As sDBName
Kill sDBCompactLockName
ReindexDatabase = True
Screen.MousePointer = vbDefault
End Function