unit2.pas

ziptv为delphi控件

Unit Unit2;

Interface

Uses
   Windows,
   Messages,
   SysUtils,
   Classes,
   Graphics,
   Controls,
   Forms,
   Dialogs,
   StdCtrls,
   Buttons,
   ComCtrls,
   Gauges,
   ExtCtrls,
   Menus,
   ztvRegister,
   ztvBase,
   ztvGbls,
   Err_Msgs,
   ztvZipCheck;

Type
   TfrmTestArchive = Class(TForm)
      ZipCheck1: TZipCheck;
      Panel1: TPanel;
      Panel2: TPanel;
      pnlStatus: TPanel;
      Label2: TLabel;
      Label3: TLabel;
      imgLed: TImage;
      pbxLed: TPaintBox;
      edtArchiveFile: TEdit;
      edtFileSpec: TEdit;
      StatusBar1: TStatusBar;
      btnOK: TBitBtn;
      btnClose: TBitBtn;
      Gauge1: TGauge;
      Gauge2: TGauge;
      Memo1: TMemo;
      CheckBox1: TCheckBox;
      Procedure FormActivate(Sender: TObject);
      Procedure btnOKClick(Sender: TObject);
      Procedure btnCloseClick(Sender: TObject);
      Procedure pbxLedPaint(Sender: TObject);
      Procedure SetLedColor(lColor: TColor);
      Procedure pbxLedClick(Sender: TObject);
      Procedure ZipCheck1Status(Sender: TObject; FN: String; PassFail: Boolean);
      Procedure ZipCheck1Error(Sender: TObject; FN, MsgEx, VolumeID: String; ECode:
         Integer);
      Procedure ZipCheck1GetPassword(Sender: TObject; FN: String; Var Password: String;
         Var TryAgain: Boolean);
      Procedure ZipCheck1Begin(Sender: TObject; FN: String; RecNum: Integer; Var Extract:
         Boolean);
      Procedure ZipCheck1Activate(Sender: TObject);
      Procedure ZipCheck1Deactivate(Sender: TObject);
      Procedure ZipCheck1Progress(Sender: TObject; ProgressByFile, ProgressByArchive:
         Byte);
      Procedure ZipCheck1NextVolume(Sender: TObject; Var VolumeName: String;
         VolumeID: Integer; FExists: Boolean; Var Cancel: Boolean);
      Procedure ZipCheck1CorruptZipHeader(Sender: TObject; HeadFlag:
         THeaderTypeState; Var Cancel: Boolean);
      Procedure ZipCheck1NestedTarFile(Sender: TObject; FileName: String; Var DoUnTar:
         Boolean);
      Procedure ZipCheck1FileExists(Sender: TObject; FileName: String;
         Var NewFileName: String; Var OverwriteMode: TOverwriteMode);
      Procedure edtFileSpecKeyPress(Sender: TObject; Var Key: Char);
      Procedure ZipCheck1ChangeArchive(Sender: TObject; ArchiveName: String;
         ArcType: TArcType);
   Private
      { Private declarations }
   Public
      { Public declarations }
   End;

Var
   frmTestArchive: TfrmTestArchive;

Implementation

Uses Unit1,
   Unit3;

//Uses
//   Main;

{$R *.DFM}
{$I defines.inc} //use our TZipView or Delphi's slow TListView control?

Var
   Busy: Boolean = False;

   //-------------------------------------------------------------

Procedure TfrmTestArchive.FormActivate(Sender: TObject);
Const
   (* Column Headers *)
   COLUMN_FILENAME = 0;
   COLUMN_FOLDER = 7;
   COLUMN_VOLUMENAME = 12;
Begin
   Memo1.Clear();
   Gauge1.Progress := 0;
   Gauge2.Progress := 0;
   //   edtFileSpec.Text := '';                        //clear for reassignment
   //   {$IFDEF ListView}
   //   With frmMain.ListView1 Do
   //      If Selected <> Nil Then
   //         edtFileSpec.Text := Selected.SubItems[COLUMN_FOLDER - 1] + Selected.Caption;
   //   {$ELSE}
   //   With frmMain.ZipView1 Do
   //      If ( SelCount > 0 ) And ( ItemIndex > -1 ) Then
   //         edtFileSpec.Text := Column[ItemIndex, COLUMN_FOLDER] +
   //            Column[ItemIndex, COLUMN_FILENAME];
   //   {$ENDIF}

   If edtFileSpec.Text = '' Then
      edtFileSpec.Text := Form1.ZipTV1.FileSpec[0];

   edtArchiveFile.Text := Form1.ZipTV1.ArchiveFile;
   edtFileSpec.SetFocus();
End;
//-------------------------------------------------------------
(* Ok button click event *)

Procedure TfrmTestArchive.btnOKClick(Sender: TObject);
Begin
   If Busy Then
      Exit;

   Memo1.Cursor := crHourGlass;
   Gauge1.Progress := 0;
   Gauge2.Progress := 0;

   Busy := True;
   btnOK.Enabled := False;
   btnClose.Enabled := False;
   Try
      Memo1.Clear();
      Memo1.Lines.BeginUpdate();

      ZipCheck1.FileSpec.Clear();
      ZipCheck1.FileSpec.Add(edtFileSpec.Text);
      ZipCheck1.RecurseDirs := CheckBox1.Checked;
      ZipCheck1.ArchiveFile := edtArchiveFile.Text;

      If ZipCheck1.IsArcDecompressable(ZipCheck1.ArcType) Then
         ZipCheck1.Activate()
      Else
         ShowMessage(LoadStr(E_INVALIDARC));

      Memo1.Lines.EndUpdate();
   Finally
      Memo1.Cursor := crDefault;
      edtFileSpec.SetFocus;
      btnOK.Enabled := True;
      btnClose.Enabled := True;
      Busy := False;
   End;
End;
//-------------------------------------------------------------

Procedure TfrmTestArchive.btnCloseClick(Sender: TObject);
Begin
   Close;
End;
//-------------------------------------------------------------
(* TZipCheck OnStatus Event - display validation pass/fail *)

Procedure TfrmTestArchive.ZipCheck1Status(Sender: TObject; FN: String; PassFail:
   Boolean);
Var
   s: String;
Begin
   If PassFail Then
      s := FN + ' ...Ok'
   Else
      s := FN + ' ...Failed';

   Memo1.Lines.Add(s);
End;
//-------------------------------------------------------------
(* TZipCheck OnError event *)

Procedure TfrmTestArchive.ZipCheck1Error(Sender: TObject; FN, MsgEx,
   VolumeID: String; ECode: Integer);
Begin
   Form1.ZipTV1Error(Sender, FN, MsgEx, VolumeID, ECode);
End;
//-------------------------------------------------------------
(* TZipCheck OnGetPassword event - request password from user *)

Procedure TfrmTestArchive.ZipCheck1GetPassword(Sender: TObject; FN: String;
   Var Password: String; Var TryAgain: Boolean);
Begin
   (* InputQuery is a Delphi function *)
   If Not InputQuery('Enter password...', LowerCase(ExtractFilename(FN)), Password) Then
      TryAgain := False;
End;
//-------------------------------------------------------------
(* TZipCheck OnBegin event - activated prior to verifing a compressed file *)

Procedure TfrmTestArchive.ZipCheck1Begin(Sender: TObject; FN: String;
   RecNum: Integer; Var Extract: Boolean);
Begin
   StatusBar1.SimpleText := 'Verifying:  ' + FN;
   StatusBar1.Update();
End;
//-------------------------------------------------------------
(* OnActivate event - activated prior to verification of any compressed files *)

Procedure TfrmTestArchive.ZipCheck1Activate(Sender: TObject);
Begin
   SetLedColor(clRed);
End;
//-------------------------------------------------------------
(* OnDeactivate event - activated after all files have been verified *)

Procedure TfrmTestArchive.ZipCheck1Deactivate(Sender: TObject);
Begin
   SetLedColor(clGreen);
   If ZipCheck1.Cancel Then
      StatusBar1.SimpleText := 'User canceled...'
   Else
      StatusBar1.SimpleText := '';

   edtArchiveFile.Text := ZipCheck1.ArchiveFile;
End;
//-------------------------------------------------------------
(* OnProgress event - activated in increments of ProgressNotify property *)

Procedure TfrmTestArchive.ZipCheck1Progress(Sender: TObject; ProgressByFile,
   ProgressByArchive: Byte);
Begin
   Gauge1.Progress := ProgressByFile;
   Gauge2.Progress := ProgressByArchive;
   Application.ProcessMessages;
End;
//-------------------------------------------------------------
(* Little light in right corner of form *)

Procedure TfrmTestArchive.pbxLedPaint(Sender: TObject);
Begin
   With Sender As TPaintBox Do
      Canvas.Draw((Width - imgLed.Width) Div 2,
         (Height - imgLed.Height) Div 2, imgLed.Picture.Graphic);
End;
//-------------------------------------------------------------
(* Change colors of little light in corner of form *)

Procedure TfrmTestArchive.SetLedColor(lColor: TColor);
Begin
   With imgLed.Canvas Do
   Begin
      Brush.Color := lColor;
      FloodFill(6, 6, Pixels[6, 6], fsSurface);
   End;
   pbxLed.Repaint();
End;
//-------------------------------------------------------------
(* Cancel operation on current archive - see note at top of module *)

Procedure TfrmTestArchive.pbxLedClick(Sender: TObject);
Begin
   StatusBar1.SimpleText := 'Aborting...';
   ZipCheck1.Cancel := True;
End;
//-------------------------------------------------------------
(* OnNextVolume event ( for multi-volume archives *)

Procedure TfrmTestArchive.ZipCheck1NextVolume(Sender: TObject; Var VolumeName: String;
   VolumeID: Integer; FExists: Boolean; Var Cancel: Boolean);
Var
   NewFile, Prompt, Caption: String;
Begin
   Cancel := False;                     (* Default value = true *)

   If (Not FExists) Then                (* FExists = FileExists *)
   Begin
      Caption := ExtractFilename(VolumeName);
      Prompt := 'Volume ID: ' + IntToStr(VolumeID);
      NewFile := VolumeName;

      If Not InputQuery(Caption, Prompt, NewFile) Then
         Cancel := True
      Else
         VolumeName := NewFile;
   End;
   edtArchiveFile.Text := NewFile;
End;
//-------------------------------------------------------------
(* OnCorruptZipHeader event 																	 	*)
(* Only problem headers in zip archives will ever call this event               *)
(*                                                                            	*)
(*                                                                              *)
(* HeadFlag parameter:                                                          *)
(*       (there are other possible combinations not listed below)               *)
(*                                                                              *)
(*    HeadFlag AND LocalHeader > 0                                              *)
(*       (local zip header was found)                                           *)
(*                                                                              *)
(*    HeadFlag AND CentralHeader > 0                                            *)
(*       (central zip header was found)                                         *)
(*                                                                              *)
(*    HeadFlag AND EndingHeader > 0                                             *)
(*       (ending zip header was found)                                          *)
(*                                                                              *)
(*    HeadFlag AND (LocalHeader + CentralHeader) > 0                            *)
(*       (ending zip header is missing/corrupt)                                 *)
(*                                                                              *)
(*    HeadFlag AND (CentralHeader + EndingHeader) > 0                           *)
(*       (local zip header is missing)                                          *)
(*                                                                              *)
(*    HeadFlag AND (LocalHeader + CentralHeader + EndingHeader) > 0             *)
(*       (all zip headers were found)                                           *)
(*                                                                              *)
(* Set "cancel" as true to interrupt processing of a bad archive... otherwise 	*)
(* processing continues with data recovery functionss 								 	*)

Procedure TfrmTestArchive.ZipCheck1CorruptZipHeader(Sender: TObject; HeadFlag:
   THeaderTypeState; Var Cancel: Boolean);
Begin
   Memo1.Lines.Add('--> OnCorruptZipHeader Event <--');

   If Not (htLocal In HeadFlag) Then
      Memo1.Lines.Add('LOCAL header missing or corrupt...');

   If Not ((htCentral In HeadFlag) And (htEnding In HeadFlag)) Then
      Memo1.Lines.Add('Header error... (missing or corrupt)');

   Memo1.Lines.Add('');
   Cancel := False; //setting this to true will terminate the active process
End;
//-------------------------------------------------------------
(* OnNestedTarFile event *)

Procedure TfrmTestArchive.ZipCheck1NestedTarFile(Sender: TObject; FileName: String; Var
   DoUnTar: Boolean);
Var
   CR, CRCR: String;
Begin
   CR := #13;
   CRCR := CR + CR;

   If MessageDlg('OnNestedTarFile Event (unit8.pas)' + CRCR +
      'File: ' + FileName + CR +
      'Compressed file is a tar archive.' + CRCR +
      'Decompress and verify this archive?',
      mtInformation, [mbYes, mbNo], 0) = mrYes Then
      DoUnTar := True;

End;
//-------------------------------------------------------------
(* OnFileExists event *)

Procedure TfrmTestArchive.ZipCheck1FileExists(Sender: TObject; FileName: String;
   Var NewFileName: String; Var OverwriteMode: TOverwriteMode);
Var
   FormResult: TModalResult;
Begin

   With frmOverwrite, Edit1 Do
   Begin
      Text := FileName;                 //set the frmOverwrite.Edit1 control text
      FormResult := ShowModal();        //show the frmOverwrite form
      NewFileName := Text;              //assign the NewFilename parameter
   End;

   Case FormResult Of
      mrNo: OverwriteMode := omSkip;
      mrYes: OverwriteMode := omOverwrite;
      mrCancel: TZipCommon(Sender).Cancel := True;
   End;

   TZipCommon(Sender).ConfirmOverwrites := Not frmOverwrite.CheckBox1.Checked;
End;
//-------------------------------------------------------------

Procedure TfrmTestArchive.edtFileSpecKeyPress(Sender: TObject; Var Key: Char);
Begin
   If (Key = #13) And (edtFileSpec.Text <> '') Then
   Begin
      btnOKClick(Sender);
      edtFileSpec.SetFocus();
      edtFileSpec.SelStart := 0;
      edtFileSpec.SelLength := Length(edtFileSpec.Text);
   End;
End;
//-------------------------------------------------------------
(* TUnGZip's OnChangeArchive Event *)

Procedure TfrmTestArchive.ZipCheck1ChangeArchive(Sender: TObject;
   ArchiveName: String; ArcType: TArcType);
Begin
   edtArchiveFile.Text := ArchiveName;
   ZipCheck1.ArchiveFile := ArchiveName;
End;
//-------------------------------------------------------------

End.