ucompress.pas

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

unit UCompress;

interface

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

Const
  Comp='正在进行数据压缩，请等候...';
  UnComp='如需继续请单击窗体，否则程序将在%d秒后退出';
  wait='等待中...';
  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;
    Edit1: TEdit;
    Button1: TButton;
    XPManifest1: TXPManifest;
    Edit2: TEdit;
    Button2: TButton;
    Label2: TLabel;
    OpenDialog1: TOpenDialog;
    Label3: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormClick(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    BusyIcon:TAniIcon;
    AccessFileName:String;//ACCESS文件路径
    ExecFileName:String;//系统可执行文件路径
    Password:String;//ACCESS数据库密码
    FDelay:Integer;
    IsExpand:Boolean;
    CanCom:Boolean;
    Procedure CampactAccessDB(const FileName,Password: String);//Access数据库压缩
    procedure DoCampact(var MSG:TMessage);message WM_CAMPAST;//运行压缩消息
    procedure SetParam(Str:String);
    procedure SetDelay(Value:Integer);
    procedure SetExpand(Value:Boolean);
    procedure SetCanCom(Value:Boolean);
    procedure LoadAniRes(Name, Style: String;var AniIco: TAniIcon);
  public
    property Com:Boolean read CanCom write SetCanCom;
    property Expand:Boolean read ISExpand write SetExpand;
    property Param:String write SetParam;
    property Delay:Integer read FDelay Write SetDelay;
  end;

var
  frmCompress: TFrmCompress;

implementation
uses ShellAPI;

{$R *.dfm}
{$R MRes.Res}

procedure TFrmCompress.FormClick(Sender: TObject);
begin
  Expand:=True;
end;

//-- 加载 Res对象的函数
procedure TFrmCompress.LoadAniRes(Name,Style:String;var AniIco:TAniIcon);
var 
 Res: TResourceStream;
begin
   try
     Timer1.Enabled:=False;
     AniIco.Destroy;
     AniIco:=TAniIcon.Create;
     Res := TResourceStream.Create(HInstance,PChar(Name),PChar(Style));
     AniIco.Animate;
     AniIco.LoadFromStream(Res);
   finally
     Res.Free;
     Timer1.Enabled:=True;
   end;
end;

//-- 创建 TAniICon 对象 加载Ani文件
procedure TFrmCompress.FormCreate(Sender: TObject);
begin
 Delay:=0;
 Font:=Screen.IconFont;
 BusyIcon:=TAniIcon.Create;
 LoadAniRes('WFree','FreeAni',BusyIcon);
 Expand:=False;
 Com:=False;
end;

procedure TFrmCompress.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
   
end;

//-- 绘制Ani，并且增加延时，其实也就是调用SetDelay方法，便于退出，高！
procedure TFrmCompress.Timer1Timer(Sender: TObject);
begin
  BusyIcon.Animate;
  BusyIcon.Draw (Canvas, Rect (30, 20, BusyIcon.Width+30, BusyIcon.Height+20));
  if not Expand then  // 没有展开的时候，且不符合压缩条件，则计时
   if not Com then Delay:=Delay+1;     // 增加延时
end;

procedure TFrmCompress.Button2Click(Sender: TObject);
begin
 if Edit1.Text<>'' then
 begin
   Param:=Format('/b:%s/p:%s',[Edit1.Text,Edit2.Text]);  //传递参数
   Expand:=False;                                        //折叠
   PostMessage(Handle,WM_CAMPAST,0,0);                   //压缩
 end;
end;

Procedure TFrmCompress.CampactAccessDB(const FileName,Password: String);
var
  vJE:OleVariant;
  tempfile:String;
begin
 LoadAniRes('WBusy','BusyANI',BusyIcon);   // 加载BusyAni
  Screen.Cursor:=crHourGlass;
  Timer1Timer(nil);
  tempfile:=ExtractFilePath(FileName)+'tmpDB.mdb';  // 临时文件路径
  Try
    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;
    LoadAniRes('WFree','FreeAni',BusyIcon);  // 加载FreeAni
  end;
end;

//-- 主函数，进行测试、压缩及运行程序
procedure TFrmCompress.DoCampact(var MSG:TMessage);
  function IsFileInUse(fName : string) : boolean;
  var
    HFileRes : HFILE;
  begin
    Result := false;
    if not FileExists(fName) then //文件不存在，则退出，返回False
       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
    // 文件是否存在及是否被占用
 if AccessFileName<>'' then         // 文件是否为空
 if FileExists(AccessFileName) then begin
    if IsFileInUse(AccessFileName) then begin  
      Timer1.Enabled:=False;  // 先暂停
      ShowMessage('其他程序可能正在使用文件 '+AccessFileName+'，请关闭后再执行！');
      Timer1.Enabled:=True;   // 再开启
      Exit;
    end;

    // 压缩数据库主函数，在这里实现
    CampactAccessDB(AccessFileName,Password);
    Com:=False;
  end;
    // 运行外部程序，不管文件是否存在，支持空格。
 // if FileExists(ExecFileName) then
    if Trim(ExecFileName)<>'' then
   // ShellExecute(Handle,'Open',PChar(ExecFileName),'/s','',SW_SHOWNORMAL);
    WinExec(PChar(ExecFileName),SW_SHOWNORMAL);
end;

//-- 激发  DoCampact 消息
procedure TFrmCompress.FormShow(Sender: TObject);
begin
  PostMessage(Handle,WM_CAMPAST,0,0);
end;

//-- 新定义的字符拆分函数
function SplitStr(Str:String;Sty:Integer):String;
  function GetBigger(Base:Integer;J,K:Integer):Integer;
  begin
    Result:=0;
    if J<>K then  // J=k 时，即两个都是0
    begin
      if J>K then  // 返回一个比Base大且最近的数
       if K>Base then Result:=K;
       if (J>Base)and(K<Base) then  Result:=J
      else // J<K
       if J>Base then Result:=J;
       if (K>Base)and(J<Base) then Result:=K;
    end;
  end;
var
 I,J,K:Integer;
 M:Integer;        //   /b:xx. md b/p: s d/r:dd ss . e x e
begin
 I:=Pos('/b:',Str);
 J:=Pos('/p:',Str);
 K:=Pos('/r:',Str);
 Result:='';
 case Sty of
  1:
    begin
     M:=GetBigger(I,J,K);
     if I<>0 then  
     if M<>0 then Result:=Copy(Str,I+3,M-I-3) else Result:=Copy(Str,I+3,Length(Str))
    end;
  2:
    begin
     M:=GetBigger(J,I,K);
     if J<>0 then   
     if M<>0 then Result:=Copy(Str,J+3,M-J-3) else Result:=Copy(Str,J+3,Length(Str))
    end;
  3:
    begin
     M:=GetBigger(K,I,J);
     if K<>0 then   
     if M<>0 then Result:=Copy(Str,K+3,M-K-3) else Result:=Copy(Str,K+3,Length(Str))
    end;
 end;
end;

//-- 拆分Str字符串,并赋值
procedure TFrmCompress.SetParam(Str:String);
begin
  Str:=StringReplace(Str,'%20',' ',[rfReplaceAll]);
  AccessFileName:=SplitStr(Str,1);
  Password:=SplitStr(Str,2);
  ExecFileName:=SplitStr(Str,3);
  if (AccessFileName='')and(ExecFileName='') then
     Com:=False    
     else
     Com:=True;   // 符合条件，则Go
end;

//-- FDelay 的控制函数
procedure TFrmCompress.SetCanCom(Value: Boolean);
begin
 CanCom:=Value;
 if CanCom then      // 压缩条件全，则改变标题
  label1.Caption:=Comp;
end;

procedure TFrmCompress.SetDelay(Value:Integer);
begin
  FDelay:=Value;
  if FDelay>100 then
      close
  else
  begin
    if not Expand then
    begin
     if not CanCom then   // 压缩条件不全，则计时 
     Label1.Caption:=Format(UnComp,[5-Trunc(FDelay/20)]);
    end else
     Label1.Caption:=wait;
  end;
end;

procedure TFrmCompress.SetExpand(Value: Boolean);
begin
 ISExpand:=Value;
 Delay:=0;
 if ISExpand then
 begin
   height:=180;
 end else
 begin
   Height:=100;
 end;
end;

procedure TFrmCompress.Button1Click(Sender: TObject);
begin
 Delay:=0;
 if Opendialog1.Execute then
   Edit1.Text:=Opendialog1.FileName;
end;

end.