Const Provider = "Microsoft.Jet.OLEDB.4.0" 
Const PathMDB = "c:\FkClnt1\DATA\client.mdb" 
Dim jro, cnn, fso, file, sSource, sDestination, fSuccess, ErrMsg 
Dim BasePath, BaseName, BaseTemp 
Dim I 
I = InstrRev(PathMDB, "\") 
BasePath = Left(PathMDB, I) 
BaseName = Mid(PathMDB, I+1) 
BaseTemp = "~compact.mdb" 
Set cnn = CreateObject("ADODB.Connection") 
cnn.Provider = Provider 
cnn.Properties("Data Source") = BasePath & BaseName 
cnn.Properties("User Id") = "admin" 
cnn.Properties("Password") = "" 
sSource = cnn.ConnectionString 
cnn.Properties("Data Source") = BasePath & BaseTemp 
sDestination = cnn.ConnectionString 
Set cnn = Nothing 
Set jro = CreateObject("JRO.JetEngine") 
On Error Resume Next 
jro.CompactDatabase sSource, sDestination 
fSuccess = (Err.Number = 0) 
ErrMsg = Err.Description 
On Error GoTo 0 
Set jro = Nothing 
If fSuccess Then 
  Set fso = CreateObject("Scripting.FileSystemObject") 
  If fso.FileExists(BasePath & BaseName) Then fso.DeleteFile BasePath & BaseName 
  Set file = fso.GetFile(BasePath & BaseTemp) 
  file.Name = BaseName 
  Set file = Nothing 
  MsgBox "Сжатие базы данных завершено." 
  Set fso = Nothing 
Else 
  MsgBox "Не удалось выполнить сжатие базы данных." & vbNewLine & ErrMsg 
End If