zwiz.pas

一个兼容pkzip的文件/内存压缩算法

unit Zwiz;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, StdCtrls, Buttons, FileCtrl, azip, fZip;

type
  TfrmWizard = class(TForm)
    imgWizard: TImage;
    grpStep1: TGroupBox;
    lblArchiveName: TLabel;
    edtArchive: TEdit;
    shpLine: TShape;
    btnCancel: TSpeedButton;
    btnBack: TSpeedButton;
    btnNext: TSpeedButton;
    btnFinish: TSpeedButton;
    btnBrowse: TSpeedButton;
    grpStep2: TGroupBox;
    grpStep3: TGroupBox;
    grpStep4: TGroupBox;
    grpStep5: TGroupBox;
    GroupBox1: TGroupBox;
    grpPassword: TGroupBox;
    grpCompression: TGroupBox;
    radPathNo: TRadioButton;
    radPathYes: TRadioButton;
    radPasswordYes: TRadioButton;
    radPasswordNo: TRadioButton;
    lblPassword: TLabel;
    edtPassword: TEdit;
    radCompressNone: TRadioButton;
    radCompressMinimum: TRadioButton;
    radCompressNormal: TRadioButton;
    radCompressMaximum: TRadioButton;
    lblFiles: TLabel;
    lstFiles: TFileListBox;
    dirFiles: TDirectoryListBox;
    drvFiles: TDriveComboBox;
    btnAdd: TSpeedButton;
    btnRemove: TSpeedButton;
    lstSelected: TListBox;
    grpMultiDisk: TGroupBox;
    radMultiNo: TRadioButton;
    radMultiYes: TRadioButton;
    grpLFN: TGroupBox;
    radLFNYes: TRadioButton;
    radLFNNo: TRadioButton;
    grpComment: TGroupBox;
    radCommentNo: TRadioButton;
    radCommentYes: TRadioButton;
    mmoComment: TMemo;
    mmoSummary: TMemo;
    procedure btnCancelClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure btnBackClick(Sender: TObject);
    procedure btnNextClick(Sender: TObject);
    procedure edtArchiveChange(Sender: TObject);
    procedure btnFinishClick(Sender: TObject);
    procedure btnAddClick(Sender: TObject);
    procedure btnRemoveClick(Sender: TObject);
    procedure lstFilesClick(Sender: TObject);
    procedure dirFilesChange(Sender: TObject);
    procedure radCommentNoClick(Sender: TObject);
    procedure radCommentYesClick(Sender: TObject);
    procedure radPasswordNoClick(Sender: TObject);
    procedure radPasswordYesClick(Sender: TObject);
    procedure btnBrowseClick(Sender: TObject);
  private
    { Private declarations }
    procedure AlignGroups;
    procedure HideGroup(GroupNum : Integer);
    procedure ShowGroup(GroupNum : Integer);
    Function CheckFloppyDrives (cFileName : String) : Boolean;
    procedure DisplaySummary;
    function Trim(s : string) : string;
    procedure WMGetMinMaxInfo(var MSG: Tmessage); message WM_GetMinMaxInfo;
  public
    { Public declarations }
  end;

var
  frmWizard: TfrmWizard;
  m_iStep : Integer;

  Const m_cMaxSteps = 5;

implementation

{$R *.DFM}

procedure TfrmWizard.btnCancelClick(Sender: TObject);
begin
   Close;
end;

procedure TfrmWizard.FormClose(Sender: TObject; var Action: TCloseAction);
begin
   Action := caFree;
end;

procedure TfrmWizard.FormShow(Sender: TObject);
var
   I: Integer;
begin

    I := addZIP_SetParentWindowHandle(frmWizard.Handle);
    m_iStep := 1;
    AlignGroups;
    grpStep1.Visible := True;
    grpStep2.Visible := False;
    grpStep3.Visible := False;
    grpStep4.Visible := False;
    grpStep5.Visible := False;
    mmoSummary.Color := clBtnFace;

end;

procedure TfrmWizard.AlignGroups;
begin
   grpStep2.Top := GrpStep1.Top;
   grpStep2.Left := GrpStep1.Left;
   grpStep2.Width := GrpStep1.Width;
   grpStep2.Height := GrpStep1.height;
   grpStep3.Top := GrpStep1.Top;
   grpStep3.Left := GrpStep1.Left;
   grpStep3.Width := GrpStep1.Width;
   grpStep3.Height := GrpStep1.height;
   grpStep4.Top := GrpStep1.Top;
   grpStep4.Left := GrpStep1.Left;
   grpStep4.Width := GrpStep1.Width;
   grpStep4.Height := GrpStep1.height;
   grpStep5.Top := GrpStep1.Top;
   grpStep5.Left := GrpStep1.Left;
   grpStep5.Width := GrpStep1.Width;
   grpStep5.Height := GrpStep1.height;

end;

procedure TfrmWizard.btnBackClick(Sender: TObject);
begin
    If (m_iStep > 1) Then
       begin
          HideGroup(m_iStep);
          If (m_iStep = m_cMaxSteps) Then
              btnNext.Enabled := True;
          m_iStep := m_iStep - 1;
          If (m_iStep = 1) Then
              btnBack.Enabled := False;
          ShowGroup(m_iStep);
       End;

end;

procedure TfrmWizard.HideGroup(GroupNum : Integer);
begin
  case GroupNum of { which group to disable }
  1 : begin
         grpStep1.Visible := False
      end;
  2 : begin
         grpStep2.Visible := False
      end;
  3 : begin
         grpStep3.Visible := False
      end;
  4 : begin
         grpStep4.Visible := False
      end;
  5 : begin
         grpStep5.Visible := False
      end;
  end; { case }
end;

procedure TfrmWizard.ShowGroup(GroupNum : Integer);
begin
  case GroupNum of { which group to disable }
  1 : begin
         grpStep1.Visible := True
      end;
  2 : begin
         grpStep2.Visible := True
      end;
  3 : begin
         grpStep3.Visible := True
      end;
  4 : begin
         grpStep4.Visible := True
      end;
  5 : begin
         grpStep5.Visible := True
      end;
  end; { case }
end;

procedure TfrmWizard.btnNextClick(Sender: TObject);
begin


    If (m_iStep < m_cMaxSteps) Then
       begin
          HideGroup(m_iStep);
          If (m_iStep = 1) Then
              btnBack.Enabled := True;
              If (Pos(':', edtArchive.Text) > 0) Then
                 begin
                    If CheckFloppyDrives(edtArchive.Text) = False Then
                       begin
                          grpMultiDisk.Enabled := False;
                          radMultiNo.Enabled := False;
                          radMultiYes.Enabled := False;
                       end
                    Else
                        begin
                           grpMultiDisk.Enabled := True;
                           radMultiNo.Enabled := True;
                           radMultiYes.Enabled := True;
                        end
                 end
              Else
                 begin
                    grpMultiDisk.Enabled := False;
                    radMultiNo.Enabled := False;
                    radMultiYes.Enabled := False;
                 End
          End;
          m_iStep := m_iStep + 1;
          If (m_iStep = m_cMaxSteps) Then
             begin
                btnNext.Enabled := False;
                DisplaySummary;
             End;
          ShowGroup(m_iStep);
    End;


Function TfrmWizard.CheckFloppyDrives (cFileName : String) : Boolean;
var
   {$IFDEF WIN32}
   pFileName : PChar;
   wResult : Word;
   {$ELSE}
   Drive : String;
   DriveNumber, wResult : Word;
   {$ENDIF}
begin

   CheckFloppyDrives := False;

   {$IFDEF WIN32}
   pFileName := StrAlloc(2);
   StrPCopy(pFileName, Copy(UpperCase(cFileName), 1, 1));
   wResult := GetDriveType(pFileName);
   StrDispose(pFileName);
   {$ELSE}
   Drive := UpperCase(Copy(cFileName, 1, 1));
   DriveNumber := Ord(Drive[1]) - 65;  {Drive must be upper case}
   wResult := Word(GetDriveType(DriveNumber));
   {$ENDIF}

   If wResult = DRIVE_REMOVABLE then
      CheckFloppyDrives := True;
End;

procedure TfrmWizard.DisplaySummary;
var
  sSummary : String;
  I : Integer;
  sFill : array[1..10] of Char;
begin
    sFill := '          ';
    mmoSummary.Clear;

    sSummary := 'Compress the following ' + IntToStr(lstSelected.Items.Count) + ' file';
    If (lstSelected.items.Count > 1) Then
        sSummary := sSummary + 's';

    sSummary := sSummary + ' to the archive ' + edtArchive.Text + '.';

    mmoSummary.Lines.Add(sSummary);
    mmoSummary.Lines.Add('');

    For I := 0 To lstSelected.items.Count - 1 do
        begin
           sSummary := sFill + lstSelected.Items[I];
           mmoSummary.Lines.Add(sSummary);
        end;

    mmoSummary.Lines.Add('');

    sSummary := 'Selected options ';
    mmoSummary.Lines.Add(sSummary);

    If (radPathYes.Checked = True) Then
        sSummary := sFill + 'Full path information saved'
    Else
        sSummary := sFill + 'Only filenames saved';

    mmoSummary.Lines.Add(sSummary);

    If (radPasswordYes.Checked = True) Then
        sSummary := sFill + 'Files will be encrypted'
    Else
        sSummary := sFill + 'Files will not be encrypted';

    mmoSummary.Lines.Add(sSummary);

    If (radCompressNone.Checked = True) Then
        sSummary := sFill + 'Files will be stored without compression'
    Else If (radCompressMinimum.Checked = True) Then
        sSummary := sFill + 'Files will hame minimum compressed'
    Else If (radCompressNormal.Checked = True) Then
        sSummary := sFill + 'Files will have normal compression'
    Else
        sSummary := sFill + 'Files will have maximum compression';

    mmoSummary.Lines.Add(sSummary);

    If (radMultiYes.Checked = True) Then
        sSummary := sFill + 'Archive may span multiple disks'
    Else
        sSummary := sFill + 'Archive will not span disks';

    mmoSummary.Lines.Add(sSummary);

    If (radLFNYes.Checked = True) Then
        sSummary := sFill + 'Long filenames will be stored'
    Else
        sSummary := sFill + 'Short (8.3) filenames will be stored';

    mmoSummary.Lines.Add(sSummary);

    If (radCommentYes.Checked = True) Then
       begin
          sSummary := sFill + 'Archive will have a comment added';
          mmoSummary.Lines.Add(sSummary);
       end;
end;

procedure TfrmWizard.edtArchiveChange(Sender: TObject);
begin
    If (Length(edtArchive.Text) = 0) Then
        btnNext.Enabled := False
    Else
        btnNext.Enabled := True;
end;

{Supresses leading and trailing blanks}
function TfrmWizard.Trim(s : string) : string;
var
  sLen : byte absolute s;
begin
  while (sLen>0) and (s[1] in [' ',^I]) do
    Delete(s,1,1);

  while (sLen>0) and (s[sLen] in [' ',^I]) do
    Dec(sLen);

  result:=s;
end;

procedure TfrmWizard.btnFinishClick(Sender: TObject);
begin
   If (grpStep5.Visible = False) Then
       begin
          DisplaySummary;
          HideGroup(m_iStep);
          ShowGroup(m_cMaxSteps);
          m_iStep := m_cMaxSteps;
       End;
   with TfrmZip.Create(Application) do
   try
      sArchiveName := edtArchive.Text;
      ShowModal;
   finally
      Free;
   end;
   Close;

end;

procedure TfrmWizard.btnAddClick(Sender: TObject);
var
   sFilename : String;
begin
    sFilename := lstFiles.Filename;
    lstSelected.Items.Add(LowerCase(sFilename));
    If (lstSelected.items.Count = 1) Then
       begin
          btnNext.Enabled := True;
          btnFinish.Enabled := True;
          btnRemove.Enabled := True;
       end;

end;

procedure TfrmWizard.btnRemoveClick(Sender: TObject);
begin
    lstSelected.Items.Delete(lstSelected.ItemIndex);
    If (lstSelected.Items.Count = 0) Then
       begin
          btnNext.Enabled := False;
          btnFinish.Enabled := False;
          btnRemove.Enabled := False;
       End;

end;

procedure TfrmWizard.lstFilesClick(Sender: TObject);
begin
   btnAdd.Enabled := True;
end;

procedure TfrmWizard.dirFilesChange(Sender: TObject);
begin
   btnAdd.Enabled := False;
end;

procedure TfrmWizard.radCommentNoClick(Sender: TObject);
begin
    If (radCommentNo.Checked = True) Then
        mmoComment.Enabled := False;
end;

procedure TfrmWizard.radCommentYesClick(Sender: TObject);
begin
    If (radCommentYes.Checked = True) Then
       mmoComment.Enabled := True;
end;

procedure TfrmWizard.radPasswordNoClick(Sender: TObject);
begin
    If (radPasswordNo.Checked = True) Then
       begin
          edtPassword.Enabled := False;
          lblPassword.Enabled := False;
       End;
end;

procedure TfrmWizard.radPasswordYesClick(Sender: TObject);
begin
    If (radPasswordYes.Checked = True) Then
       begin
          edtPassword.Enabled := True;
          lblPassword.Enabled := True;
       End;
end;

procedure TfrmWizard.btnBrowseClick(Sender: TObject);
begin

   with TOpenDialog.Create(Self) do
   try
      Title := 'Enter a name for a .ZIP archive';
      Filename := '';
      InitialDir := ExtractFilepath(Application.ExeName);
      DefaultExt := '.ZIP';
      Filter := 'ZIP Files (*.ZIP)|*.ZIP|All Files (*.*)|*.*';
      FilterIndex := 1;
      HelpContext := 0;
      Options := Options + [ofPathMustExist];

      if Execute then
         begin
            If Trim(Filename) <> '' Then
               edtArchive.Text := Filename
            Else
               edtArchive.Text := '';
         End
      Else
         edtArchive.Text := ''
   finally
     Free
   end;

end;

procedure TfrmWizard.WMGetMinMaxInfo(var MSG: Tmessage);
Begin
  inherited;
  with PMinMaxInfo(MSG.lparam)^ do
  begin
    with ptMaxTrackSize do
    begin
      X := 504;
      Y := 420;
    end;
    with ptMinTrackSize do
    begin
      X := 504;
      Y := 420;
    end;
  end;
end;

end.