unit2.pas

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: String; 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: String; 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: ' + 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.