main.~pas

一个用于测试不同加密方式及压缩方式下文件压缩的速度和大小的工具。

unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, RXSpin, StdCtrls, Buttons, ExtCtrls, ComCtrls, Mask, ToolEdit,
  WjhCps;

type
  Tfrmmain = class(TForm)
    WjhCps1: TWjhCps;
    Ed1: TFilenameEdit;
    Ed2: TFilenameEdit;
    frmProgress: TProgressBar;
    Label1: TLabel;
    Label2: TLabel;
    RadioGroup1: TRadioGroup;
    GroupBox1: TGroupBox;
    Memo1: TMemo;
    Panel1: TPanel;
    BitBtn1: TBitBtn;
    GroupBox2: TGroupBox;
    BitBtn2: TBitBtn;
    BitBtn3: TBitBtn;
    Label3: TLabel;
    Label4: TLabel;
    Ed4: TEdit;
    Ed3: TRxSpinEdit;
    Label5: TLabel;
    procedure RadioGroup1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure WjhCps1FileProgress(Sender: TObject; FileName: string;
      Progress: Double; Operation: TWuCProcessOperation;
      ProgressPhase: TWuCProgressPhase; var Cancel: Boolean);
    procedure WjhCps1OverallProgress(Sender: TObject; Progress: Double;
      Operation: TWuCProcessOperation; ProgressPhase: TWuCProgressPhase;
      var Cancel: Boolean);
    procedure WjhCps1ExtractFile(Sender: TObject; var FileName: string;
      var FileAttr: Cardinal; const Comment: string);
    procedure Ed1Change(Sender: TObject);
  private
    cmping: boolean;
    Cryptostr: string;
    dwreadTime: Longword;
    fsStream: TMemoryStream;
    fname: string;
    CryptoAlgor: TWuCCryptoAlgorithm;
    procedure getfname(idx: integer);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmmain: Tfrmmain;

implementation

{$R *.dfm}

procedure Tfrmmain.getfname(idx: integer);
var
  ftdir: string;
begin
  fname := '000000' + inttostr(ed3.AsInteger) + inttostr(idx + 1);
  fname := copy(fname, length(fname) - 6, length(fname));
  ftdir := ExtractFileDir(ed1.Text);
  if (Length(ftdir) > 0) and (ftdir[Length(ftdir)] <> '\') then
    ftdir := ftdir + '\';
  ed2.Text := ftdir + fname;
end;

procedure Tfrmmain.RadioGroup1Click(Sender: TObject);
begin
  case RadioGroup1.ItemIndex of
    0:
      begin
        CryptoAlgor := caBlowfish;
        Cryptostr := 'caBlowfish';
      end;
    1:
      begin
        CryptoAlgor := caRijndael_128;
        Cryptostr := 'caRijndael_128';
      end;
    2:
      begin
        CryptoAlgor := caRijndael_256;
        Cryptostr := 'caRijndael_256';
      end;
    3:
      begin
        CryptoAlgor := caDES_Single;
        Cryptostr := 'caDES_Single';
      end;
    4:
      begin
        CryptoAlgor := caDES_Triple;
        Cryptostr := 'caDES_Triple';
      end;
    5:
      begin
        CryptoAlgor := caTwofish_128;
        Cryptostr := 'caTwofish_128';
      end;
    6:
      begin
        CryptoAlgor := caTwofish_256;
        Cryptostr := 'caTwofish_256';
      end;
    7:
      begin
        CryptoAlgor := caSquare;
        Cryptostr := 'caSquare';
      end;
  end;

  getfname(RadioGroup1.ItemIndex);
end;

procedure Tfrmmain.FormCreate(Sender: TObject);
begin
  cmping := false;
  CryptoAlgor := caBlowfish;
  Cryptostr := 'caBlowfish';
  fsStream := TMemoryStream.Create;

end;

procedure Tfrmmain.BitBtn1Click(Sender: TObject);
begin
  if cmping then
    exit;
  try
    cmping := true;
    dwreadTime := GetTickCount;
    WjhCps1.FileName := ed2.Text;
    WjhCps1.F0EC9DB8 := Uppercase(ExtractFileName(ed2.Text)) + Ed4.Text;
    WjhCps1.CryptoAlgorithm := CryptoAlgor;
    WjhCps1.CompressionMode := Ed3.AsInteger;
    WjhCps1.OpenArchive(fmCreate);
    WjhCps1.BaseDir := ExtractFileDir(ed1.Text);
    WjhCps1.AddFiles(Ed1.Text);
    WjhCps1.CloseArchive;
    dwreadTime := GetTickCount - dwreadTime;
  finally
    Memo1.Lines.Add('压缩    加密: ' + Cryptostr + '   压缩模式: ' + Ed3.Text + ' 密码长度: ' + inttostr(length(Uppercase(ExtractFileName(ed2.Text)) + Ed4.Text)) + '   耗时: ' + inttostr(dwreadTime));
    cmping := false;
  end;
end;

procedure Tfrmmain.BitBtn2Click(Sender: TObject);
begin
  if cmping then
    exit;
  fsStream.Position := 0;
  fsStream.SetSize(0);
  try
    cmping := true;
    dwreadTime := GetTickCount;
    WjhCps1.CryptoAlgorithm := CryptoAlgor;
    WjhCps1.Options.ShareMode := smShareDenyNone;
    WjhCps1.CompressionMode := Ed3.AsInteger;
    WjhCps1.F0EC9DB8 := UpperCase(ExtractFileName(Ed2.Text)) + Ed4.Text;
    WjhCps1.FileName := Ed2.Text;
    WjhCps1.OpenArchive(fmOpenRead);
    WjhCps1.ExtractToStream(ExtractFileName(Ed1.Text), fsStream);
    fsStream.Seek(0, 0);
    dwreadTime := GetTickCount - dwreadTime;
  finally
    Memo1.Lines.Add('解压    加密: ' + Cryptostr + '   压缩模式: ' + Ed3.Text + ' 密码长度: ' + inttostr(length(Uppercase(ExtractFileName(ed2.Text)) + Ed4.Text)) + '   耗时: ' + inttostr(dwreadTime));
    WjhCps1.CloseArchive;
    cmping := false;
  end;
end;

procedure Tfrmmain.FormDestroy(Sender: TObject);
begin
  fsStream.Free;
  fsStream := nil;
end;

procedure Tfrmmain.WjhCps1FileProgress(Sender: TObject; FileName: string;
  Progress: Double; Operation: TWuCProcessOperation;
  ProgressPhase: TWuCProgressPhase; var Cancel: Boolean);
begin
  if (ProgressPhase = ppStart) then
  begin
    frmProgress.Visible := true;
    Label5.Visible := true;
  end
  else
    if (ProgressPhase = ppEnd) then
    begin
      frmProgress.Visible := false;
      Label5.Visible := false;
    end;
  Label5.Caption := inttostr(Round(Progress));
  frmProgress.Position := Round(Progress);
  Application.ProcessMessages;
end;

procedure Tfrmmain.WjhCps1OverallProgress(Sender: TObject;
  Progress: Double; Operation: TWuCProcessOperation;
  ProgressPhase: TWuCProgressPhase; var Cancel: Boolean);
begin
  if (ProgressPhase = ppStart) then
  begin
    frmProgress.Visible := true;
    Label5.Visible := true;
  end
  else
    if (ProgressPhase = ppEnd) then
    begin
      frmProgress.Visible := false;
      Label5.Visible := false;
    end;
  Label5.Caption := inttostr(Round(Progress));
  frmProgress.Position := Round(Progress);
  Application.ProcessMessages;
end;

procedure Tfrmmain.WjhCps1ExtractFile(Sender: TObject;
  var FileName: string; var FileAttr: Cardinal; const Comment: string);
begin
  frmProgress.Visible := true;
  Label5.Visible := true;
end;

procedure Tfrmmain.Ed1Change(Sender: TObject);
begin
  getfname(RadioGroup1.ItemIndex);
end;

end.