ucompress.pas

支持Access自动压缩及运行程序

unit UCompress;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, uCAniIcon, ExtCtrls, StdCtrls, ComObj;

Const
  DEFAULT_DELIMITERS = [';',#9, #10, #13];
  WM_CAMPAST=WM_USER+$1008;
  SConnectionString='Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%s;'
                                +'Jet OLEDB:Database Password=%s;';
type
  TFrmCompress = class(TForm)
    Timer1: TTimer;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    BusyIcon:TAniIcon;
    AccessFileName:String;//ACCESS文件路径
    ExecFileName:String;//系统可执行文件路径
    Password:String;//ACCESS数据库密码
    FDelay:Integer;
    function GetAbsoluePath(RelFileName:String):String;//获取绝对路径
    Procedure CampactAccessDB(const FileName,Password: String);//Access数据库压缩
    procedure DoCampact(var MSG:TMessage);message WM_CAMPAST;//运行压缩消息
    procedure SetParam(Str:String);
    procedure SetDelay(Value:Integer);
  public
    property Param:String write SetParam;
    property Delay:Integer read FDelay Write SetDelay;
  end;

var
  frmCompress: TFrmCompress;

implementation
uses ShellAPI;

{$R *.dfm}

function GetToKen(Str :String;Index :Integer;bTrail: Boolean = False; Delimiters: TSysCharSet = DEFAULT_DELIMITERS): string;
var
  Head,Detail,I,W :Integer;
begin
  Head := 1;
  Detail := 1;
  I := 1;
  W := 1;
  While (I<Index)and(W<=Length(Str)) do
  begin
    if Str[W] in Delimiters then begin I := I+1;Head := W+1;End;
    W := W+1;
  end;
  While W<=Length(Str) do
  begin
    if Str[W] in Delimiters then begin I := I+1;Detail := W;break;End;
    W := W+1;
  end;
  if I < Index then begin Result :='';Exit;End;
  if w > Length(Str) then Detail := Length(Str)+1;
  if Head >=Detail then begin Result := '';Exit;End;
  Result := Copy(Str,Head,Detail-Head);
end;


function TFrmCompress.GetAbsoluePath(RelFileName:String):String;
begin
  result:=ExtractFilePath(Application.ExeName)+RelFileName;
end;

procedure TFrmCompress.FormCreate(Sender: TObject);
begin
 Delay:=0;
 Font:=Screen.IconFont;
 BusyIcon:=TAniIcon.Create;
 if FileExists(GetAbsoluePath('Resource\Busy.ani')) then
    BusyIcon.LoadFromFile(GetAbsoluePath('Resource\Busy.ani'));
 


end;

procedure TFrmCompress.Timer1Timer(Sender: TObject);
begin
  BusyIcon.Animate;
  BusyIcon.Draw (Canvas, Rect (20, 15, BusyIcon.Width+20, BusyIcon.Height+15));
  Delay:=Delay+1;

end;

Procedure TFrmCompress.CampactAccessDB(const FileName,Password: String);
var
//  OleDB:OLEVariant;
  vJE:OleVariant;
  tempfile:String;
begin
  Screen.Cursor:=crHourGlass;
  Timer1Timer(nil);
  tempfile:=ExtractFilePath(FileName)+'tmpDB.mdb';
  Try
{    OleDB:=CreateOleObject('DAO.DBEngine.36');//'DAO.DBEngine.36'也可以,不知道是不是access2000要用dao3.6,我在access97上用35和36都可以
    Application.ProcessMessages;              //这种方法不能适用于有密码的数据库
    OleDB.CompactDatabase(FileName,tempfile);
    Application.ProcessMessages;
    DeleteFile(FileName);
    Application.ProcessMessages;
    RenameFile(tempfile,FileName);}
    Application.ProcessMessages;
    vJE:=CreateOleObject('JRO.JetEngine');
    Application.ProcessMessages;
    vJE.CompactDatabase(format(SConnectionString,[FileName,Password]),
        format(SConnectionString,[tempFile,Password]));
    Application.ProcessMessages;
    DeleteFile(FileName);
    Application.ProcessMessages;
    RenameFile(tempfile,FileName);


  finally
    Screen.Cursor:=crDefault;
//    Application.Terminate;
  end;
end;

procedure TFrmCompress.DoCampact(var MSG:TMessage);
  function IsFileInUse(fName : string) : boolean;
  var
    HFileRes : HFILE;
  begin
    Result := false;
    if not FileExists(fName) then
       exit;
    HFileRes := CreateFile(pchar(fName), GENERIC_READ or GENERIC_WRITE,
                0 {this is the trick!}, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
    Result := (HFileRes = INVALID_HANDLE_VALUE);
    if not Result then
    CloseHandle(HFileRes);
  end;

begin
//CampactAccessDB('我的账本.acc','');
  if FileExists(AccessFileName) then begin
    if IsFileInUse(AccessFileName) then begin
      Timer1.Enabled:=False;
      ShowMessage('其他程序可能正在使用文件 '+AccessFileName+'，请关闭后再执行！');
      Timer1.Enabled:=True;
      Exit;
    end;
    CampactAccessDB(AccessFileName,Password);
  end;
  if FileExists(ExecFileName) then
    ShellExecute(Handle,'Open',PChar(ExecFileName),'','',SW_SHOWNORMAL);

end;

procedure TFrmCompress.FormShow(Sender: TObject);
begin
  PostMessage(Handle,WM_CAMPAST,0,0);
end;

procedure TFrmCompress.SetParam(Str:String);
begin
  Str:=StringReplace(Str,'%20',' ',[rfReplaceAll]);
  AccessFileName:=GetToKen(Str,1);
  Password:=GetToKen(Str,2);
  ExecFileName:=GetToKen(Str,3);
end;

procedure TFrmCompress.SetDelay(Value:Integer);
begin
  FDelay:=Value;
  if FDelay>10 then Close;
end;

end.