zip.pas

天涯進銷存系統

{ ********************************************************************************** }
{                                                                                    }
{ 	 COPYRIGHT 1997 Kevin Boylan                                                    }
{     Source File: Unzip.pas                                                         }
{     Description: VCLUnZip component demo - native Delphi unzip component.          }
{     Date:        March 1997                                                        }
{     Author:      Kevin Boylan, CIS: boylank                                        }
{                                Internet: [e-mail]                    }
{                                                                                    }
{ ********************************************************************************** }
unit zip;
{$P-}

{  Sun 29 Mar 1998   10:49:13    Version: 2.1
{ Version 2.1 additions
{
{ - Capability of 16bit VCLZip to store long filenames/paths
{ when running on 32 bit OS.
{ - New Store83Names property to force storing short
{ filenames and paths
{ - Better UNC path support.
{ - Fixed a bug to allow adding files to an empty archive.
}
{
{  Tue 24 Mar 1998   19:03:57
{ Modifications to allow storing filenames and paths in DOS
{ 8.3 format
}
{
{  Wed 11 Mar 1998   20:58:48  Version: 2.03
{ Version 2.03, Fixed several bugs.
}

interface

uses
   {$IFDEF SNOOPING}
   snoop,
   {$ENDIF}
   {$IFDEF WIN32}
   Windows, ComCtrls,
   {$ELSE}
   WinTypes, WinProcs,
   {$ENDIF}
   SysUtils, Messages, ShellAPI, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, ExtCtrls, Buttons,
   Menus, Gauges, IncZip, Tabnotbk, IniFiles, OvrWrite, KPLib,
   VCLZip, VCLUnZip, kpZipObj, kpSFXCfg;

type
   TConfigInfo = record
      DefaultViewer: string;
      ForceDefaultViewer: Boolean;
      LowerCaseFiles: Boolean;
   end;

   TVCLZipForm = class(TForm)
      Panel1: TPanel;
      ExtractBtn: TSpeedButton;
      OpenZipBtn: TSpeedButton;
      StatusBar: TPanel;
      Header1: THeader;
      MainMenu1: TMainMenu;
      FileMenu: TMenuItem;
      Open1: TMenuItem;
      Close1: TMenuItem;
      N1: TMenuItem;
      Exit1: TMenuItem;
      Action1: TMenuItem;
      Unzip1: TMenuItem;
      Sort1: TMenuItem;
      None1: TMenuItem;
      FileName1: TMenuItem;
      Dircetory1: TMenuItem;
      Date1: TMenuItem;
      Size1: TMenuItem;
      Rate1: TMenuItem;
      NoOrder: TMenuItem;
      UncompressedSize1: TMenuItem;
      Gauge1: TGauge;
      CurrentFileLabel: TLabel;
      Infowin: TMemo;
      Gauge2: TGauge;
      Label2: TLabel;
      ZipCommentMnu: TMenuItem;
      ExitBtn: TSpeedButton;
      FilesList: TListBox;
      ClearLogWindow1: TMenuItem;
      FileSelectDlg: TOpenDialog;
      Help1: TMenuItem;
      About1: TMenuItem;
      RenameDlg: TSaveDialog;
      AddBtn: TSpeedButton;
      NewZipBtn: TSpeedButton;
      New1: TMenuItem;
      Add1: TMenuItem;
      Configure1: TMenuItem;
      N2: TMenuItem;
      ConfigBtn: TSpeedButton;
      DeleteBtn: TSpeedButton;
      AbortBtn: TSpeedButton;
      BackupBtn: TSpeedButton;
      ZipCommentBtn: TSpeedButton;
      FileCommentBtn: TSpeedButton;
      SaveMenuItem: TMenuItem;
      FixMenu: TMenuItem;
      Zipper: TVCLZip;
      N3: TMenuItem;
      MakeSFX32Mnu: TMenuItem;
      Make16bitSFXMnu: TMenuItem;
      ZipSizeLabel: TLabel;
      Label1: TLabel;
      DeleteFiles: TMenuItem;
      ModifyPath: TMenuItem;
      ModifyFilename1: TMenuItem;
      N4: TMenuItem;
      TestZipFile1: TMenuItem;
      N5: TMenuItem;
      SFXtoZipMnu: TMenuItem;
    TestSelectedFiles1: TMenuItem;
      procedure ExtractBtnClick(Sender: TObject);
      procedure FormCreate(Sender: TObject);
      procedure OpenZipBtnClick(Sender: TObject);
      procedure OnExitBtn(Sender: TObject);
      procedure Close1Click(Sender: TObject);
      procedure OnSort(Sender: TObject);
      procedure Header1Sized(Sender: TObject; ASection, AWidth: Integer);
      procedure ZipperStartUnZip(Sender: TObject; FileIndex: Integer;
         var FName: string; var Skip: Boolean);
      procedure ZipperBadPassword(Sender: TObject; FileIndex: Integer; var NewPassword:
         string);
      procedure ZipperFilePercentDone(Sender: TObject; Percent: Longint);
      procedure ZipperSkippingFile(Sender: TObject; Reason: TSkipReason; FName: string;
         FileIndex: Integer; var Retry: Boolean );
      procedure ZipperPromptForOverwrite(Sender: TObject; var OverWriteIt: Boolean;
         FileIndex: Integer; var FName: string);
      procedure ZipperBadCRC(Sender: TObject; CalcCRC, StoredCRC: LongInt; FileIndex: Integer);
      procedure ZipperTotalPercentDone(Sender: TObject; Percent: LongInt);
      procedure ZipCommentMnuClick(Sender: TObject);
      procedure ZipperStartUnzipInfo(Sender: TObject; NumFiles: Integer;
         TotalBytes: Comp; var StopNow: Boolean);
      procedure ZipperGetNextDisk(Sender: TObject; NextDisk: Integer; var FName: string);
      procedure FilesList1DrawItem(Control: TWinControl; Index: Integer;
         Rect: TRect; State: TOwnerDrawState);
      procedure FilesList1MeasureItem(Control: TWinControl; Index: Integer;
         var Height: Integer);
      procedure ZipperInCompleteZip(Sender: TObject;
         var IncompleteMode: TIncompleteZipMode);
      procedure ClearLogWindow1Click(Sender: TObject);
      procedure FilesListDblClick(Sender: TObject);
      procedure FormClose(Sender: TObject; var Action: TCloseAction);
      procedure About1Click(Sender: TObject);
      procedure NewZipBtnClick(Sender: TObject);
      procedure OnAddFiles(Sender: TObject);
      procedure FormKeyUp(Sender: TObject; var Key: Word;
         Shift: TShiftState);
      procedure Configure1Click(Sender: TObject);
      procedure ZipperStartZip(Sender: TObject; FName: string;
         var ZipHeader: TZipHeaderInfo; var Skip: Boolean);
      procedure DeleteBtnClick(Sender: TObject);
      procedure AbortBtnClick(Sender: TObject);
      procedure BackupBtnClick(Sender: TObject);
      procedure SaveMenuItemClick(Sender: TObject);
      procedure FileCommentBtnClick(Sender: TObject);
      procedure FileMenuClick(Sender: TObject);
      procedure FixMenuClick(Sender: TObject);
      procedure MakeSFX32MnuClick(Sender: TObject);
      procedure Make16bitSFXMnuClick(Sender: TObject);
      procedure ZipperEndZip(Sender: TObject; FName: string;
         UncompressedSize, CompressedSize, CurrentZipSize: LongInt);
      procedure ZipperStartZipInfo(Sender: TObject; NumFiles: Integer;
         TotalBytes: Comp; var EndCentralRecord: TEndCentral; var StopNow: Boolean);
      procedure ZipperDeleteEntry(Sender: TObject; FName: string;
         var Skip: Boolean);
      procedure ZipperDisposeFile(Sender: TObject; FName: string;
         var Skip: Boolean);
      procedure ModifyPathClick(Sender: TObject);
      procedure ModifyFilename1Click(Sender: TObject);
      procedure TestZipFile1Click(Sender: TObject);
      procedure SFXtoZipMnuClick(Sender: TObject);
      procedure ZipperUnZipComplete(sender: TObject; FileCount: Integer);
    procedure ZipperUpdate(Sender: TObject; UDAction: TUpdateAction;
      FileIndex: Integer);
    procedure TestSelectedFiles1Click(Sender: TObject);
    procedure ZipperRecursingFile(Sender: TObject; FName: String);
   PRIVATE
      { Private declarations }
      procedure OpenTheZip;
      procedure InitHeaderWidths;
      procedure CleanupViewList;
      procedure ReadIni;
      procedure WriteIni;
      procedure AddFiles;
      procedure MakeFilesListFromListBox;
      procedure DeleteFromZip;
      procedure SetLogging;
      procedure UpdateExtractDlg;
      procedure GetExtractDlgInfo;
      procedure UpdateCompressDlg;
      procedure GetCompressDlgInfo;
      procedure UpdateConfigDlg;
      procedure GetConfigDlgInfo;
      procedure MakeSFX(Stub: string);
   PROTECTED
      procedure Loaded; OVERRIDE;

   PUBLIC
      { Public declarations }
   end;

var
   VCLZipForm                 : TVCLZipForm;
   CheckedSortItem            : TMenuItem;
   ViewFilesList              : TStringList;
   ZipFromDir                 : string;
   ConfigInfo                 : TConfigInfo;
   sfx16, sfx32               : string;
   Testing                    : Boolean;
   checkZipper                : TVCLUnZip;
   zipcounter                 : Integer;

implementation

uses Extract, Compress, Config, Comment, ModInfo, InvPwd;

{$R *.DFM}

procedure TVCLZipForm.FormCreate(Sender: TObject);
var
   CommandLine                : string;
   ArgPos                     : Integer;
begin
   {  ReadIni;   }
   InitHeaderWidths;
   CheckedSortItem := NoOrder;
   CheckedSortItem.Checked := True;
   ViewFilesList := TStringList.Create;
   { WIN32 includes module path\filename in cmdline }
   CommandLine := PCharToStr(CmdLine);
   {$IFDEF WIN32}
   ArgPos := Pos(' ', CommandLine);
   if (ArgPos = 0) or (ArgPos = Length(CommandLine)) then
      CommandLine := ''
   else
      CommandLine := Copy(CommandLine, ArgPos + 1, Length(CommandLine));
   {$ENDIF}
   if (CommandLine = '') or (not (File_Exists(CommandLine))) then
      Zipper.ZipName := '' { just to seed the initial directory for }
   else { the open zip dialog box                }
   begin
      Zipper.ZipName := CommandLine;
      OpenTheZip;
   end;
   Zipper.PreserveStubs := True;
   Testing := False;
   zipcounter := 0;
   Zipper.FileOpenMode := fmShareDenyNone;
end;

procedure TVCLZipForm.Loaded;
begin
   inherited Loaded;
   ReadIni;
end;

procedure TVCLZipForm.MakeFilesListFromListBox;
var
   i                          : Integer;
begin
   Zipper.FilesList.Clear;
   for i := 0 to VCLZipForm.FilesList.Items.Count - 1 do
      if VCLZipForm.FilesList.Selected[i] then
         Zipper.Selected[i] := True;
         {Zipper.FilesList.Add(Zipper.FullName[i]);}
end;

procedure TVCLZipForm.UpdateExtractDlg;
begin
   Zipper.FilesList.Clear;                              {added 10/15/97 KLB}
   with ExtractDlg do
   begin
      if FilesList.SelCount > 0 then
         SelectedFiles.Checked := True
      else
         AllFilesRBtn.Checked := True;
      DestDir.Text := Zipper.DestDir;
      RelDir.Text := '';
      Overwrite.ItemIndex := Ord(Zipper.OverwriteMode);
      RecreateDir.Checked := Zipper.RecreateDirs;
      RetainAttributesChk.Checked := Zipper.RetainAttributes;
      Password.Text := Zipper.Password;
   end;
end;

procedure TVCLZipForm.GetExtractDlgInfo;
begin
   with ExtractDlg do
   begin
      Zipper.DoAll := AllFilesRBtn.Checked;
      Zipper.DestDir := DestDir.Text;
      Zipper.RootDir := RelDir.Text;
      Zipper.OverwriteMode := TUZOverwriteMode(Overwrite.ItemIndex);
      Zipper.RecreateDirs := RecreateDir.Checked;
      Zipper.RetainAttributes := RetainAttributesChk.Checked;
      Zipper.Password := Password.Text;
   end;
end;

procedure TVCLZipForm.ExtractBtnClick(Sender: TObject);
var
   NumUnZipped                : Integer;
begin
   NumUnZipped := 0;
   try
      if Zipper.Count = 0 then
      begin
         MessageBeep(0);
         exit;
      end;
      with Zipper do
      begin
         UpdateExtractDlg;
         if ExtractDlg.ShowModal <> mrOK then
            exit;
         GetExtractDlgInfo;
         if DoAll then
         begin
            Screen.Cursor := crHourGlass;
            NumUnZipped := UnZip;
         end
         else
         begin
            if ExtractDlg.UseMask.Checked then
             begin
               Zipper.FilesList.Add(ExtractDlg.ExtractMask.Text);
               Screen.Cursor := crHourGlass;
               NumUnZipped := UnZip;
             end
            else
             begin
               MakeFilesListFromListBox;
               Screen.Cursor := crHourGlass;
               NumUnZipped := UnZipSelected;
             end;
         end;
      end;
   finally
      Gauge1.Progress := 0;
      Gauge2.Progress := 0;
      CurrentFileLabel.Caption := '';
      Screen.Cursor := crDefault;
      MessageBeep(0);
      if NumUnZipped > 0 then
         InfoWin.Lines.Add(IntToStr(NumUnZipped) + ' Files Unzipped!')
      else
         if Zipper.Count > 0 then
            InfoWin.Lines.Add('无文件解压!')
   end;
end;

procedure TVCLZipForm.OpenZipBtnClick(Sender: TObject);
begin
   try
      Zipper.ZipName := ZipFromDir + '\?';
   except
      on EUserCanceled do
      begin
         Screen.Cursor := crDefault;
         exit;
      end
   else
      raise; { If not EUserCanceled then re-raise the exception }