obrarcompress.pas

很好用的Delphi文件压缩控件

{-----------------------------------------------------------------------------
 Unit Name: OBRARCompress
 Author:    OverBlue Software
 Date:      2005-09-06
-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------
OBRAR_V0.02
2005-09-15 siow 修改版 Delphi6,Delphi2005测试通过
           偶的Blog:http://blog.csdn.net/siow
           E-mail:[e-mail](不要发垃圾邮件哦^-^)
所做修改：
  1、支持目录压缩，支持通配符。
  2、支持文件和目录的列表压缩。
  3、支持文件名中带空格。
  4、去掉修改ZLib.DLL为ZLib.exe部分。
  5、默认压缩参数改为3，与WinRar默认值保持一致。
  6、将过程Compress改为函数，可返回压缩成功状态。
  7、将LeftBStr函数改为LeftStr，以兼容低于D7的版本。
  8、加入部份注释信息。
-----------------------------------------------------------------------------}
unit OBRARCompress;

interface

uses
  SysUtils, Classes, Windows, Forms, uConsole;

type
  TOnCompressing = procedure(Sender : TObject; Progress : Integer) of object;
  TOBRARCompress = class(TComponent)
  private
    FResult:Boolean;
    FCon : TRedirectedConsole;
    FCompressLevel: Integer;
    FRARFileName: String;
    FOnCompressing: TOnCompressing;
    FSourceFiles: TStringList;
    function GenderCommandLineText : String;
    procedure OnNormalOutput(Sender: TObject; Data: String);
    procedure OnErrorOutput(Sender: TObject; Data: String);
    procedure CheckZLibFile;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Compress:Boolean;
  published
    property SourceFiles : TStringList read FSourceFiles write FSourceFiles;
    property RARFileName : String read FRARFileName write FRARFileName;
    property CompressLevel : Integer read FCompressLevel write FCompressLevel;
    property OnCompressing : TOnCompressing read FOnCompressing write FOnCompressing;
  end;

procedure Register;

implementation

uses StrUtils;

procedure Register;
begin
  RegisterComponents('OBRAR', [TOBRARCompress]);
end;

{ TZipFileToRAR }

constructor TOBRARCompress.Create(AOwner: TComponent);
begin
  inherited;
  FCon := nil;
  FCompressLevel := 3;
  FSourceFiles := TStringList.Create;
end;

destructor TOBRARCompress.Destroy;
begin
  FreeAndNil(FSourceFiles);
  inherited;
end;

function TOBRARCompress.Compress:Boolean;
var
  CommandLine : String;
begin
  FResult:=false;
  CheckZLibFile;
  CommandLine := GenderCommandLineText;
  FCon := nil;
  try
    FCon := TRedirectedConsole.Create(CommandLine);
    FCon.OnStdOut := OnNormalOutput;
    FCon.OnStdErr := OnErrorOutput;
    FCon.Run;
  finally
    FreeAndNil(FCon);
    Result:=FResult;
  end;
end;

procedure TOBRARCompress.CheckZLibFile;
begin
  if not FileExists(ExtractFilePath(ParamStr(0))+'ZLib.DLL') then
  begin
    MessageBox(Application.Handle, '在当前目录没找到 ZLib.DLL 文件!',
               '错误',
               MB_ICONERROR);
    Abort;
  end;
end;

function TOBRARCompress.GenderCommandLineText: String;
var
  i : Integer;
begin
  Result := ExtractFilePath(ParamStr(0)) + 'ZLib.DLL a ' +
            '-m'+IntToStr(FCompressLevel)+' '+
            '-ep1 '+
            RARFileName+ ' ';

  for i := 0 to SourceFiles.Count -1 do
  begin
    Result := Result +'"'+SourceFiles.Strings[i] + '" ';
  end;
end;

procedure TOBRARCompress.OnErrorOutput(Sender: TObject; Data: String);
begin
  MessageBox(Application.Handle, pChar(Data), '错误', MB_ICONERROR);
  FResult:=false;
end;

procedure TOBRARCompress.OnNormalOutput(Sender: TObject; Data: String);
begin
  if (Pos('%', Data) <> 0) then
  begin
    Data := LeftStr(Data, Pos('%', Data)-1);
    Data := Trim(Data);
    if Assigned(FOnCompressing) then FOnCompressing(Sender, StrToIntDef(Data, 0));
    FResult:=true;
  end;
end;

end.