unit1.pas

ziptv为delphi控件

(* ******************************************************************
   Click on light when RED, to cancel the current operation.
   ****************************************************************** *)
Unit Unit1;

Interface

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

Type
   TForm1 = Class(TForm)
      OpenDialog1: TOpenDialog;
      ZipCheck1: TZipCheck;
      ListBox1: TListBox;
      Panel1: TPanel;
      pnlStatus: TPanel;

      imgLed: TImage;
      pbxLed: TPaintBox;
      Gauge1: TGauge;
      Gauge2: TGauge;
      StatusBar1: TStatusBar;

      btnOpenArchive: TBitBtn;
      btnOK: TBitBtn;
      btnClose: TBitBtn;

      Label2: TLabel;
      Label3: TLabel;
      edtArchiveFile: TEdit;
      edtFileSpec: TEdit;

      MainMenu1: TMainMenu;
      File1: TMenuItem;
      Open1: TMenuItem;

      Procedure pbxLedPaint(Sender: TObject);
      Procedure SetLedColor(lColor: TColor);
      Procedure btnCloseClick(Sender: TObject);
      Procedure btnOpenArchiveClick(Sender: TObject);
      Procedure FormActivate(Sender: TObject);
      Procedure btnOKClick(Sender: TObject);
      Procedure edtArchiveFileChange(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 ZipCheck1Deactivate(Sender: TObject);
      Procedure ZipCheck1Progress(Sender: TObject; ProgressByFile, ProgressByArchive:
         Byte);
      Procedure ZipCheck1Activate(Sender: TObject);
      Procedure pbxLedClick(Sender: TObject);
      Procedure ZipCheck1NextVolume(Sender: TObject; Var VolumeName: String;
         VolumeID: Integer; FExists: Boolean; Var Cancel: Boolean);
      Function FIXEDLENGTHSTR(InInt: Integer): ShortString;
      Procedure Open1Click(Sender: TObject);
      Procedure ZipCheck1CorruptZipHeader(Sender: TObject;
         HeadFlag: THeaderTypeState; Var Cancel: Boolean);
   Private
      { Private declarations }
   Public
      { Public declarations }
   End;

Var
   Form1: TForm1;

Implementation

{$R *.DFM}

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

Function TForm1.FIXEDLENGTHSTR(InInt: Integer): ShortString;
Var
   OutStr: ShortString;
Begin
   OutStr := '               ' + IntToStr(InInt);
   Result := Copy(OutStr, Length(OutStr) - 9, Length(OutStr));
End;
//-------------------------------------------------------------

Procedure TForm1.btnOpenArchiveClick(Sender: TObject);
Begin
   Open1Click(Sender);
End;
//-------------------------------------------------------------

Procedure TForm1.FormActivate(Sender: TObject);
Begin
   If ZipCheck1.FileSpec.Count > 0 Then
      edtFileSpec.Text := ZipCheck1.FileSpec[1];
End;
//-------------------------------------------------------------
(* Ok button click event *)

Procedure TForm1.btnOKClick(Sender: TObject);
Begin
   ListBox1.Cursor := crHourGlass;

   Try
      ListBox1.Clear;
      ZipCheck1.FileSpec.Clear;
      ZipCheck1.FileSpec.Add(edtFileSpec.Text);
      ZipCheck1.ArchiveFile := edtArchiveFile.Text;

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

      edtArchiveFile.SetFocus;
   Finally
      ListBox1.Cursor := crDefault;
   End;

End;
//-------------------------------------------------------------

Procedure TForm1.btnCloseClick(Sender: TObject);
Begin
   Close;
End;
//-------------------------------------------------------------
(* edit box "edtArchiveFile" OnChange event *)

Procedure TForm1.edtArchiveFileChange(Sender: TObject);
Begin
   btnOK.Enabled := edtArchiveFile.Text <> '';
End;
//-------------------------------------------------------------
(* TZipCheck OnStatus Event - display validation pass/fail *)

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

   ListBox1.Items.Add(s);
End;
//-------------------------------------------------------------
(* TZipCheck OnError event *)

Procedure TForm1.ZipCheck1Error(Sender: TObject; FN, MsgEx,
   VolumeID: String; ECode: Integer);
Begin

   ShowMessage('File   : ' + FN + #13 +
      'Error# : ' + IntToStr(ECode) + #13 +
      LoadStr(ECode));
End;
//-------------------------------------------------------------
(* TZipCheck OnGetPassword event - request password from user *)

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

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

Procedure TForm1.ZipCheck1Activate(Sender: TObject);
Begin
   SetLedColor(clRed);
   Gauge1.Visible := True;
   Gauge2.Visible := True;
End;
//-------------------------------------------------------------
(* OnDeactivate event - activated after all files have been verified *)

Procedure TForm1.ZipCheck1Deactivate(Sender: TObject);
Begin
   SetLedColor(clGreen);
   Gauge1.Progress := 0;
   Gauge2.Progress := 0;
   Gauge1.Visible := False;
   Gauge2.Visible := False;
   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 TForm1.ZipCheck1Progress(Sender: TObject; ProgressByFile, ProgressByArchive:
   Byte);
Begin
   Gauge1.Progress := ProgressByFile;
   Gauge2.Progress := ProgressByArchive;
   Application.ProcessMessages;
End;
//-------------------------------------------------------------
(* Little light in right corner of form *)

Procedure TForm1.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 TForm1.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 TForm1.pbxLedClick(Sender: TObject);
Begin
   StatusBar1.SimpleText := 'Aborting...';
   ZipCheck1.Cancel := True;
End;
//-------------------------------------------------------------
(* OnNextVolume event ( for multi-volume archives *)

Procedure TForm1.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;
//-------------------------------------------------------------

Procedure TForm1.Open1Click(Sender: TObject);
Begin
   OpenDialog1.Filter := LoadStr(F_TZIPTV);  (* see F_TZIPTV in err_msgs.rc and err_msgs.pas *)
   OpenDialog1.Options := [ofHideReadOnly, ofFileMustExist, ofPathMustExist];

   If OpenDialog1.Execute Then
   Begin
      edtArchiveFile.Text := OpenDialog1.FileName;
      ListBox1.Items.Clear;
   End;
End;
//-------------------------------------------------------------
(* OnCorruptZipHeader event 																	 	*)
(*                                                                            	*)
(* Set "cancel" as true to interrupt processing of a bad archive... otherwise 	*)
(* processing continues with reading of good headers 								 	*)

Procedure TForm1.ZipCheck1CorruptZipHeader(Sender: TObject;
   HeadFlag: THeaderTypeState; Var Cancel: Boolean);
Begin
   ListBox1.Items.Add('====================================');
   ListBox1.Items.Add('OnCorruptZipHeader Event (start)');
   ListBox1.Items.Add('====================================');

   If Not (htLocal In HeadFlag) Then
      ListBox1.Items.Add('*Local* header missing or corrupt...');

   If Not (htCentral In HeadFlag) Then
      ListBox1.Items.Add('*Central* header missing or corrupt...');

   If Not (htEnding In HeadFlag) Then
      ListBox1.Items.Add('*Ending* header missing or corrupt...');

   ListBox1.Items.Add('');
   ListBox1.Items.Add('"Cancel" parameter set to false, continuing...');
   ListBox1.Items.Add('====================================');
   ListBox1.Items.Add('OnCorruptZipHeader Event (end)');
   ListBox1.Items.Add('====================================');

   Cancel := False;
End;
//-------------------------------------------------------------

End.