Программное сжатие базы Access

procedure TMainForm.ActionCompactAccessDBExecute(Sender: TObject); 
var 
JetEngine: Variant; 
TempName: string; 
aAccess: string; 
stAccessDB: string; 
SaveCursor: TCursor; 
begin 
stAccessDB := 'Provider = Microsoft.Jet.OLEDB.4.0;' + 
'Data Source = %s;Jet OLEDB: Engine type = '; 
stAccessDB := stAccessDB + '5'; {5 for Access 2000 and 4 for Access 97} 
OpenDialog1.InitialDir := oSoftConfig.ApplicationPath + 'Data\'; 
OpenDialog1.Filter := 'MS Access (r) (*.mdb)|*.mdb'; 
if OpenDialog1.execute and (uppercase(ExtractFileExt 
(OpenDialog1.FileName)) = '.MDB') then 
begin 
if MessageDlg('This process can take several minutes. Please wait till the end ' + 
#13 + #10 + 'of it. Do you want to proceed? Press No to exit.', mtInformation, 
[mbYes, mbNo], 0) = mrNo then 
exit; 
SaveCursor := screen.cursor; 
screen.cursor := crHourGlass; 
aAccess := OpenDialog1.FileName; 
TempName := ChangeFileExt(aAccess, '.$$$'); 
DeleteFile(PChar(TempName)); 
JetEngine := CreateOleObject('JRO.JetEngine'); 
try 
JetEngine.CompactDatabase(Format(stAccessDB, [aAccess]), 
Format(stAccessDB, [TempName])); 
DeleteFile(PChar(aAccess)); 
RenameFile(TempName, aAccess); 
finally 
JetEngine := Unassigned; 
screen.cursor := SaveCursor; 
end; 
end; 
end;

Procedure CompactDatabase_JRO(DatabaseName:String;DestDatabaseName:String='';Password:String='');
Const
  Provider = 'Provider=Microsoft.Jet.OLEDB.4.0;';
Var
  TempName : Array[0..MAX_PATH] of Char; 
  TempPath : String; 
  Name : String;
  Src,Dest : WideString;
  V : Variant;
begin
  try
      Src := Provider + 'Data Source=' + DatabaseName;
      if DestDatabaseName<>'' then
          Name:=DestDatabaseName
      else begin
          TempPath:=ExtractFilePath(DatabaseName);
          if TempPath='' Then TempPath:=GetCurrentDir;
          GetTempFileName(PChar(TempPath),'mdb',0,TempName);
          Name:=StrPas(TempName);
      end;
      DeleteFile(PChar(Name));
      Dest := Provider + 'Data Source=' + Name;
      if Password<>'' then begin
          Src := Src + ';Jet OLEDB:Database Password=' + Password;
          Dest := Dest + ';Jet OLEDB:Database Password=' + Password;
      end;
      V:=CreateOleObject('jro.JetEngine');
      try
          V.CompactDatabase(Src,Dest);
      finally
          V:=0;
      end;
      if DestDatabaseName='' then begin 
          DeleteFile(PChar(DatabaseName)); 
          RenameFile(Name,DatabaseName); 
      end;
  except
    on E: Exception do ShowMessage(e.message);
  end;
end;

procedure TMain.Button3Click(Sender: TObject);
Var path,db,db1:string;
begin
   GetDir(0,path);
   db:=path+'\Table\newBD.mdb';
   With DM do begin
      ADOconnection1.Close;
   end;
   CompactDatabase_JRO(db,'','');
   With DM do begin
      ADOconnection1.Open;
      TblMain.Open;
      TblName.Open;
      .... открываем таблицы
   end;
end;

if TempPath='' then
        TempPath:=GetCurrentDir;

function CompactDatabase_JRO(DatabaseName: string; Password: string = ''): Boolean;
var
  Src, Dest: WideString;
  V: Variant;
begin
  try
    var TempName := ExtractFilePath(DatabaseName) + 'mdbPunchCAM';
    DeleteFile(TempName);
    const Provider = 'Provider=Microsoft.Jet.OLEDB.4.0;';
    Src := Provider + 'Data Source=' + DatabaseName;
    Dest := Provider + 'Data Source=' + TempName;
    if Password <> '' then begin
      Src := Src + ';Jet OLEDB:Database Password=' + Password;
      Dest := Dest + ';Jet OLEDB:Database Password=' + Password;
    end;
 
    V := CreateOleObject('jro.JetEngine');
    try
      V.CompactDatabase(Src, Dest);
    finally
      V := 0;
    end;
 
    DeleteFile(DatabaseName);
    RenameFile(TempName, DatabaseName);
  except
    ShowMessage('{C6CDA928-9093-4441-9855-6A1CA4992E4F}');
    Result := False;
    Exit;
  end;
  Result := True;
end;