cm_main.pas

类似于WinRAR的压缩工具

unit Cm_Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ComCtrls, ZLibEx;

type
  TForm1 = class(TForm)
    GroupBox1: TGroupBox;
    Label1: TLabel;
    Edit1: TEdit;
    Button1: TButton;
    Label2: TLabel;
    Button2: TButton;
    Edit2: TEdit;
    GroupBox2: TGroupBox;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    GroupBox3: TGroupBox;
    RadioButton3: TRadioButton;
    RadioButton4: TRadioButton;
    RadioButton5: TRadioButton;
    RadioButton6: TRadioButton;
    GroupBox4: TGroupBox;
    ProgressBar1: TProgressBar;
    Panel1: TPanel;
    Button3: TButton;
    Button4: TButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    procedure Edit1Change(Sender: TObject);
    procedure RadioButton1Click(Sender: TObject);
    procedure RadioButton2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure OnProgress(dwBytesDone, dwBytesTotal: DWord);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{$R WindowsXP.res}

const
     Z_NO_FLUSH = 0;
     Z_STREAM_END = 1;
     Z_FINISH = 4;

     ZLevels: Array [TZCompressionLevel] of ShortInt = (0, 1, -1, 9);

     ZErrMsg: Array [0..9] of PChar = (
      'Need dictionary',
      'Stream end',
      '',
      'File error',
      'Stream error',
      'Data error',
      'Insufficient memory',
      'Buffer error',
      'Incompatible version',
      '');

procedure TForm1.OnProgress(dwBytesDone, dwBytesTotal: DWord);
begin
     ProgressBar1.Position := dwBytesDone * 100 div dwBytesTotal;
     Panel1.Caption := Format('%d%%', [dwBytesDone * 100 div dwBytesTotal]);
     Application.ProcessMessages;
end;

function ZCompressCheck(Code: Integer): Integer;
begin
     Result := Code;
     if Code < 0 then
        Raise EZCompressionError.Create(ZErrMsg[2 - Code]);
end;

procedure Compress(InStream, OutStream: TMemoryStream; Level: TZCompressionLevel);
var
   ZStream: TZStreamRec;
   lpInBuffer, lpOutBuffer: Pointer;
   ZResult, InSize, OutSize: Integer;
begin
     FillChar(ZStream, SizeOf(TZStreamRec), 0);
     ZCompressCheck(DeflateInit_(ZStream,
                                 ZLevels[Level],
                                 '1.2.3',
                                 SizeOf(TZStreamRec)));
     GetMem(lpInBuffer, 10240);
     GetMem(lpOutBuffer, 10240);
     InSize := InStream.Read(lpInBuffer^, 10240);
     While InSize > 0 do
           begin
                ZStream.next_in := lpInBuffer;
                ZStream.avail_in := InSize;
                Repeat
                      ZStream.next_out := lpOutBuffer;
                      ZStream.avail_out := 10240;
                      ZCompressCheck(deflate(ZStream, Z_NO_FLUSH));
                      OutSize := 10240 - ZStream.avail_out;
                      OutStream.Write(lpOutBuffer^, OutSize);
                      Form1.OnProgress(InStream.Position, InStream.Size);
                Until (ZStream.avail_in = 0) and (ZStream.avail_out > 0);
                InSize := InStream.Read(lpInBuffer^, 10240);
           end;
     Repeat
           ZStream.next_out := lpOutBuffer;
           ZStream.avail_out := 10240;
           ZResult := ZCompressCheck(deflate(ZStream, Z_FINISH));
           OutSize := 10240 - ZStream.avail_out;
           OutStream.Write(lpOutBuffer^, OutSize);
           Form1.OnProgress(InStream.Position, InStream.Size);
     Until (ZResult = Z_STREAM_END) and (ZStream.avail_out > 0);
     ZCompressCheck(deflateEnd(ZStream));
     FreeMem(lpInBuffer);
     FreeMem(lpOutBuffer);
end;

procedure Decompress(InStream, OutStream: TMemoryStream);
var
   ZStream: TZStreamRec;
   lpInBuffer, lpOutBuffer: Pointer;
   ZResult, InSize, OutSize: Integer;
begin
     FillChar(ZStream, SizeOf(TZStreamRec), 0);
     ZCompressCheck(InflateInit_(ZStream,
                                 '1.2.3',
                                 SizeOf(TZStreamRec)));
     GetMem(lpInBuffer, 10240);
     GetMem(lpOutBuffer, 10240);
     InSize := InStream.Read(lpInBuffer^, 10240);
     While InSize > 0 do
           begin
                ZStream.next_in := lpInBuffer;
                ZStream.avail_in := InSize;
                Repeat
                      ZStream.next_out := lpOutBuffer;
                      ZStream.avail_out := 10240;
                      ZCompressCheck(inflate(ZStream, Z_NO_FLUSH));
                      OutSize := 10240 - ZStream.avail_out;
                      OutStream.Write(lpOutBuffer^, OutSize);
                      Form1.OnProgress(InStream.Position, InStream.Size);
                Until (ZStream.avail_in = 0) and (ZStream.avail_out > 0);
                InSize := InStream.Read(lpInBuffer^, 10240);
           end;
     Repeat
           ZStream.next_out := lpOutBuffer;
           ZStream.avail_out := 10240;
           ZResult := ZCompressCheck(inflate(ZStream, Z_FINISH));
           OutSize := 10240 - ZStream.avail_out;
           OutStream.Write(lpOutBuffer^, OutSize);
           Form1.OnProgress(InStream.Position, InStream.Size);
     Until (ZResult = Z_STREAM_END) and (ZStream.avail_out > 0);
     ZCompressCheck(inflateEnd(ZStream));
     FreeMem(lpInBuffer);
     FreeMem(lpOutBuffer);
end;

procedure TForm1.Edit1Change(Sender: TObject);
begin
     Button3.Enabled := FileExists(Edit1.Text) and
                        DirectoryExists(ExtractFilePath(Edit1.Text));
end;

procedure TForm1.RadioButton1Click(Sender: TObject);
begin
     RadioButton3.Enabled := True;
     RadioButton4.Enabled := True;
     RadioButton5.Enabled := True;
     RadioButton6.Enabled := True;
end;

procedure TForm1.RadioButton2Click(Sender: TObject);
begin
     RadioButton3.Enabled := False;
     RadioButton4.Enabled := False;
     RadioButton5.Enabled := False;
     RadioButton6.Enabled := False;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
     if OpenDialog1.Execute then Edit1.Text := OpenDialog1.FileName;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
     if SaveDialog1.Execute then Edit2.Text := SaveDialog1.FileName;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
   Src, Dest: TMemoryStream;
   Level: TZCompressionLevel;
begin
     Src := TMemoryStream.Create;
     Dest := TMemoryStream.Create;
     Edit1.Enabled := False;
     Edit2.Enabled := False;
     Button1.Enabled := False;
     Button2.Enabled := False;
     RadioButton1.Enabled := False;
     RadioButton2.Enabled := False;
     RadioButton3.Enabled := False;
     RadioButton4.Enabled := False;
     RadioButton5.Enabled := False;
     RadioButton6.Enabled := False;
     try
        try
           Src.LoadFromFile(Edit1.Text);
        except
              MessageBox(Handle,
                         'Can''t Open Input File!',
                         'Error',
                         MB_ICONERROR);
        end;
        Src.Position := 0;
        Dest.Clear;
        if RadioButton1.Checked then
           begin
                if RadioButton3.Checked then
                   Level := zcMax
                   else
                   if RadioButton4.Checked then
                      Level := zcDefault
                      else
                      if RadioButton5.Checked then
                         Level := zcFastest
                         else
                         Level := zcNone;
                try
                   Compress(Src, Dest, Level);
                   Dest.SaveToFile(Edit2.Text);
                   MessageBox(Handle,
                              PChar('Compress Finished!'#13#10 +
                                    'File Save to: "' + Edit2.Text + '" !'),
                              'Information',
                              MB_ICONINFORMATION);
                except
                      MessageBox(Handle,
                                 'Compress Failed!',
                                 'Error',
                                 MB_ICONERROR);
                end;
           end
           else
           begin
                try
                   Decompress(Src, Dest);
                   Dest.SaveToFile(Edit2.Text);
                   MessageBox(Handle,
                              PChar('Decompress Finished!'#13#10 +
                                    'File Save to: "' + Edit2.Text + '" !'),
                              'Information',
                              MB_ICONINFORMATION);
                except
                      MessageBox(Handle,
                                 'Decompress Failed!',
                                 'Error',
                                 MB_ICONERROR);
                end;
           end;
     finally
            Src.Free;
            Dest.Free;
            Edit1.Enabled := True;
            Edit2.Enabled := True;
            Button1.Enabled := True;
            Button2.Enabled := True;
            RadioButton1.Enabled := True;
            RadioButton2.Enabled := True;
            RadioButton3.Enabled := True;
            RadioButton4.Enabled := True;
            RadioButton5.Enabled := True;
            RadioButton6.Enabled := True;
     end;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
     Form1.Close;
end;

end.