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;
      Panel3: TPanel;
      pnlStatus: TPanel;
      Label1: TLabel;
      Label2: TLabel;
      Label3: TLabel;
      imgLed: TImage;
      pbxLed: TPaintBox;
      edtArchiveFile: TEdit;
      edtFileSpec: TEdit;
      StatusBar1: TStatusBar;
      Memo1: TMemo;
      btnOK: TBitBtn;
      btnClose: TBitBtn;
      Gauge1: TGauge;
      Gauge2: TGauge;
      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; FileName, MsgEx, VolumeID: String; ECode:
         Integer);
      Procedure ZipCheck1GetPassword(Sender: TObject; FileName: 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 ZipCheck1GetZipFirstDisk(Sender: TObject; Var Cancel: Boolean);
      Procedure ZipCheck1GetZipNextDisk(Sender: TObject; VolumeName: String;
         Var Cancel: Boolean);
      Procedure ZipCheck1GetZipLastDisk(Sender: TObject; 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);
   Private
      { Private declarations }
   Public
   End;

Var
   frmTestArchive: TfrmTestArchive;

Implementation

Uses
   Unit1;

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

Var
   Busy: Boolean = False;

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

Procedure TfrmTestArchive.FormActivate(Sender: TObject);
Const
   SepChar = ',';
   (* Column Headers *)
   COLUMN_FILENAME = 0;
   COLUMN_FOLDER = 7;
   COLUMN_VOLUMENAME = 12;
Begin
   Memo1.Clear();
   Gauge1.Progress := 0;
   Gauge2.Progress := 0;

   edtArchiveFile.Text := Form1.Edit1.Text;
End;
//-------------------------------------------------------------
(* Ok button click event *)

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

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

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

      ZipCheck1.FileSpec.Clear();
      //ZipCheck1.FileSpec.Add( edtFileSpec.Text );
      If edtFileSpec.Text <> '' Then
         ztvGbls.StrToTStrings(Pchar(edtFileSpec.Text), ZipCheck1.FileSpec);

      ZipCheck1.RecurseDirs := CheckBox1.Checked;
      ZipCheck1.ArchiveFile := edtArchiveFile.Text;

      // boolean value from demo's main.pas CheckBox1 control
      ZipCheck1.TranslateOemChar := False;  //frmMain.CheckBox1.Checked;  // ...foreign language chars

      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;
      edtArchiveFile.Text := ArchiveFileName;
   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; FileName, MsgEx,
   VolumeID: String; ECode: Integer);
Begin
   Form1.ArchiveEditor1Error(Sender, FileName, MsgEx, VolumeID, ECode);
End;
//-------------------------------------------------------------
(* TZipCheck OnGetPassword event - request password from user *)

Procedure TfrmTestArchive.ZipCheck1GetPassword(Sender: TObject; FileName: String;
   Var Password: String; Var TryAgain: Boolean);
Begin
   //GetPassword( Sender, FN, Password, TryAgain );

   (* InputQuery is a Delphi function *)
   If Not InputQuery(
      'Enter password...',
      LowerCase(ExtractFilename(FileName)), 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 := VolumeName;
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 htLocal > 0                                                  *)
(*       (local zip header was found)                                           *)
(*                                                                              *)
(*    HeadFlag And htCentral > 0                                                *)
(*       (central zip header was found)                                         *)
(*                                                                              *)
(*    HeadFlag And htEnding > 0                                                 *)
(*       (ending zip header was found)                                          *)
(*                                                                              *)
(*    HeadFlag And (htLocal + htCentral) > 0                                    *)
(*       (ending zip header is missing/corrupt)                                 *)
(*                                                                              *)
(*    HeadFlag And (htCentral + htEnding) > 0                                   *)
(*       (local zip header is missing)                                          *)
(*                                                                              *)
(*    HeadFlag And (htLocal + htCentral + htEnding) > 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) Then
      Memo1.Lines.Add('CENTRAL header missing or corrupt...');

   If Not (htEnding In HeadFlag) Then
      Memo1.Lines.Add('ENDING 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('--------------------------------');
   Memo1.Lines.Add('');
   Cancel := False; //setting this to true will terminate the active process
End;
//-------------------------------------------------------------

Procedure TfrmTestArchive.ZipCheck1GetZipFirstDisk(Sender: TObject; Var Cancel: Boolean);
Begin
   Application.ProcessMessages;
   Case MessageDlg('Insert FIRST disk of this archive set.', mtInformation, [mbOK,
      mbCancel], 0) Of
      mrOK: Cancel := False;
      mrCancel: ;
   End;
End;
//-------------------------------------------------------------

Procedure TfrmTestArchive.ZipCheck1GetZipNextDisk(Sender: TObject;
   VolumeName: String; Var Cancel: Boolean);
Begin
   Application.ProcessMessages;
   Case MessageDlg('Insert disk# : ' + VolumeName, mtInformation, [mbOK, mbCancel], 0) Of
      mrOK: Cancel := False;
      mrCancel: ;
   End;
End;
//-------------------------------------------------------------

Procedure TfrmTestArchive.ZipCheck1GetZipLastDisk(Sender: TObject; Var Cancel: Boolean);
Begin
   Application.ProcessMessages;
   Case MessageDlg('Insert LAST disk of this archive set.', mtInformation, [mbOK,
      mbCancel], 0) Of
      mrOK: Cancel := False;
      mrCancel: ;
   End;
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);
Begin
   //
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;
//-------------------------------------------------------------

End.