unit1.pas

ziptv为delphi控件

(*

  Here's a small demo that includes compression & decompression of
  zip archives.

  *)
Unit Unit1;

{$I ZipTV.inc}
{$IFDEF DEL6_OR_HIGHER}
{$WARN UNIT_PLATFORM OFF}
{$ENDIF}

Interface

Uses
   SysUtils,
   Classes,
   Controls,
   Forms,
   Dialogs,
   StdCtrls,
   Buttons,
   ComCtrls,
   Gauges,
   ExtCtrls,
   FileCtrl,
   ztvRegister,
   ztvBase,
   ztvConsts,
   ztvUnZip,
   ztvZip,
   ztvUnCab,
   ztvMakeCab;

Type
   TForm1 = Class(TForm)
      OpenDialog1: TOpenDialog;
      ListBox1: TListBox;
      StatusBar1: TStatusBar;

      BitBtn1: TBitBtn;
      BitBtn2: TBitBtn;
      BitBtn3: TBitBtn;
      btnCompress: TBitBtn;
      btnExtract: TBitBtn;

      Gauge1: TGauge;
      Gauge2: TGauge;

      pnlStatus: TPanel;
      Panel1: TPanel;
      Panel2: TPanel;
      Panel3: TPanel;

      Label1: TLabel;
      Label2: TLabel;
      Label3: TLabel;
      Label4: TLabel;
      Label5: TLabel;
      Label6: TLabel;

      Edit1: TEdit;
      Edit2: TEdit;
      Edit3: TEdit;
      Edit4: TEdit;
      Edit5: TEdit;

      CheckBox1: TCheckBox;
      CheckBox3: TCheckBox;
      CheckBox2: TCheckBox;
      CheckBox4: TCheckBox;

      MakeCab1: TMakeCab;
      UnCab1: TUnCAB;
      CheckBox5: TCheckBox;

      Procedure FormCreate(Sender: TObject);
      Procedure FormCloseQuery(Sender: TObject; Var CanClose: Boolean);

      Procedure btnCloseClick(Sender: TObject);
      Procedure btnCompressClick(Sender: TObject);
      Procedure btnExtractClick(Sender: TObject);

      Procedure BitBtn1Click(Sender: TObject);
      Procedure BitBtn2Click(Sender: TObject);
      Procedure BitBtn3Click(Sender: TObject);
      Procedure MakeCab1Begin(Sender: TObject; FName: String; Count: Integer;
         Var Extract: Boolean);
      Procedure MakeCab1Deactivate(Sender: TObject);
      Procedure MakeCab1Progress(Sender: TObject; ProgressByFile,
         ProgressByArchive: Byte);
      Procedure UnCab1FileExists(Sender: TObject; FileName: String;
         Var NewFileName: String; Var OverwriteMode: TOverwriteMode);
      Procedure MakeCab1Error(Sender: TObject; FileName, ExtendedMsg,
         VolumeID: String; ECode: Integer);

   Private
      { Private declarations }
   Public
      { Public declarations }
   End;

Var
   Form1: TForm1;

Implementation

Uses Unit2,
   Unit3;

{$R *.DFM}

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

Procedure TForm1.FormCreate(Sender: TObject);
Begin
   OpenDialog1.Filter := '*.ZIP';
   OpenDialog1.Options := [ofHideReadOnly, ofFileMustExist, ofPathMustExist];
End;
//-------------------------------------------------------------

Procedure TForm1.BitBtn1Click(Sender: TObject);
Begin
   If OpenDialog1.Execute Then
   Begin
      Edit1.Text := OpenDialog1.FileName;
      ListBox1.Items.Clear;
   End;
End;
//-------------------------------------------------------------

Procedure TForm1.BitBtn2Click(Sender: TObject);
Begin
   If OpenDialog1.Execute Then
   Begin
      Edit3.Text := OpenDialog1.FileName;
      ListBox1.Items.Clear;
   End;
End;
//-------------------------------------------------------------

// It is not necessary to set the values of all properties listed below.
// If you wish to use the default values, leave them out.
// Properties with "// default" are included just for this demonstration.

Procedure TForm1.btnCompressClick(Sender: TObject);
Var
   FilesCompressed: Integer;
Begin
   Cursor := crHourGlass;
   frmErrorMsgs.ListView1.Items.Clear();
   ListBox1.Clear();

   If FileExists(Edit1.Text) Then
      If MessageDlg(
         'Archive exists... overwrite?',
         mtConfirmation,
         [mbYes, mbNo],
         0) = mrYes Then
         // move to recycle bin
         EraseFile(Edit1.Text, doAllowUndo) // EraseFile is in ztvBase.pas
      Else
         Exit;

   MakeCab1.ArchiveFile := Edit1.Text;  // archive filename

   MakeCab1.DateAttribute := daFileDate; // default value
   MakeCab1.StoredDirNames := sdRelative; // default value
   MakeCab1.CompressMethod := cmDeflate; // default value
   MakeCab1.RecurseDirs := CheckBox2.Checked; // default = False
   MakeCab1.Switch := swAdd;            // default value
   //MakeCab1.StoreEmptySubDirs := False;     // default value
   //MakeCab1.EncryptHeaders := CheckBox1.Checked; // default = False

   MakeCab1.ExcludeSpec.Clear();
   MakeCab1.FileSpec.Clear();
   MakeCab1.FileSpec.Add(Edit2.Text);   // test with c:\windows\*.txt

   // ****************************************************************
   // NOTE: for a better understanding of how the Attributes property
   // works with file attributes see demo demos\filescan\fs_demo.dpr.
   // ****************************************************************

   // See the Attributes property in the object inspector
   // Set MakeCab1 Attributes property by calling the SetAttribute method
   MakeCab1.SetAttribute(fsZeroAttr, True); // default
   MakeCab1.SetAttribute(fsArchive, True); // default
   MakeCab1.SetAttribute(fsDirectory, True); // default = False
   MakeCab1.SetAttribute(fsHidden, True); // default = False
   MakeCab1.SetAttribute(fsReadOnly, True); // default
   MakeCab1.SetAttribute(fsSysFile, True); // default = False

   // See the AttributesEx property in teh object inspector
   // Set the AttributesEx property by calling the SetAttributeEx method.
   // Exclude none
   MakeCab1.SetAttributeEx(fsZeroAttr, False); // default
   MakeCab1.SetAttributeEx(fsArchive, False); // default
   MakeCab1.SetAttributeEx(fsDirectory, False); // default
   MakeCab1.SetAttributeEx(fsHidden, False); // default
   MakeCab1.SetAttributeEx(fsReadOnly, False); // default
   MakeCab1.SetAttributeEx(fsSysFile, False); // default

   // ***********************************
   // Call the Compress method
   // ***********************************
   FilesCompressed := MakeCab1.Compress();
   ShowMessage('Files Compressed: ' + IntToStr(FilesCompressed));

   Cursor := crDefault;
   If frmErrorMsgs.ListView1.Items.Count > 0 Then
      frmErrorMsgs.ShowModal();
      
End;
//-------------------------------------------------------------

Procedure TForm1.btnExtractClick(Sender: TObject);
Var
   FilesExtracted: Integer;
Begin
   UnCab1.ArchiveFile := Edit3.Text;    // archive filename

	UnCab1.OverwriteMode := omOverwrite;
   UnCab1.ConfirmOverwrites := CheckBox3.Checked; // default = False
   UnCab1.RecurseDirs := CheckBox4.Checked; // default = False
   UnCab1.UseStoredDirs := CheckBox5.Checked;

   UnCab1.FileSpec.Clear();             //
   UnCab1.FileSpec.Add(Edit4.Text);     // *.* = extract all
   UnCab1.ExtractDir := Edit5.Text;     //
   If DirectoryExists(Edit5.Text) Then  // if the directory exists then extract
   Begin
      FilesExtracted := UnCab1.Extract();
      ShowMessage('Files Extracted: ' + IntToStr(FilesExtracted));
   End
   Else
   Begin
      ShowMessage('Extract dir not defined');
      Exit;
   End;
End;
//-------------------------------------------------------------

Procedure TForm1.btnCloseClick(Sender: TObject);
Begin
   Close;
End;
//-------------------------------------------------------------

Procedure TForm1.FormCloseQuery(Sender: TObject; Var CanClose: Boolean);
Begin
   MakeCab1.Cancel := True;
   UnCab1.Cancel := True;
End;
//-------------------------------------------------------------

Procedure TForm1.BitBtn3Click(Sender: TObject);
Var
   Dir: String;
Begin
   Dir := Edit5.Text;
   If SelectDirectory(Dir, [sdAllowCreate, sdPerformCreate, sdPrompt], 0) Then
      Edit5.Text := Dir;
End;
//-------------------------------------------------------------

// OnBegin event
Procedure TForm1.MakeCab1Begin(Sender: TObject; FName: String;
   Count: Integer; Var Extract: Boolean);
Begin
   ListBox1.Items.Add(FName);
   StatusBar1.SimpleText := FName;
End;
//-------------------------------------------------------------

// OnDeactivate event
Procedure TForm1.MakeCab1Deactivate(Sender: TObject);
Begin
   //Gauge1.Progress := 0;
   //Gauge2.Progress := 0;
   StatusBar1.SimpleText := '';
End;
//-------------------------------------------------------------

// OnProgress event
Procedure TForm1.MakeCab1Progress(Sender: TObject; ProgressByFile,
   ProgressByArchive: Byte);
Begin
   Gauge1.Progress := ProgressByFile;
   Gauge2.Progress := ProgressByArchive;
   Application.ProcessMessages;
End;
//-------------------------------------------------------------

// OnFileExists event
Procedure TForm1.UnCab1FileExists(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;
//-------------------------------------------------------------

// OnError event
Procedure TForm1.MakeCab1Error(Sender: TObject; FileName, ExtendedMsg,
   VolumeID: String; ECode: Integer);
Var
   NewItem: TListItem;
Begin
   If frmErrorMsgs <> Nil Then          // has form been created?
   Begin
      NewItem := frmErrorMsgs.ListView1.Items.Insert(0); (* Create a new row *)
      With NewItem Do
      Begin
         Caption := LowerCase(Sender.Classname);
         With SubItems Do
         Begin
            Add(LowerCase(TZipCommon(Sender).ArchiveFile)); // archive FileName
            Add(LowerCase(ExtractFilename(FileName))); // FileName
            Add(IntToStr(ECode));       // convert error number to a string
            Add(LoadStr(ECode)); // Load error string from err_msgs.rc & err_msgs.pas
            Add(ExtendedMsg);           // Extended message such as required event params
         End;
      End;
   End;
End;
//-------------------------------------------------------------

End.