unit1.pas

ZIP压缩算法 delphi组件 含代码

   Try
      ListBox1.Clear();

      UnZip1.ArchiveFile := Edit3.Text;    // archive filename
      UnZip1.ConfirmOverwrites := CheckBox3.Checked; // default = False
      UnZip1.RecurseDirs := CheckBox4.Checked; // default = False
      UnZip1.UseStoredDirs := CheckBox5.Checked;
      UnZip1.FileSpec.Clear();             //
      UnZip1.FileSpec.Add(Edit4.Text);     // *.* = extract all
      UnZip1.ExtractDir := Edit5.Text;     //
      If DirectoryExists(Edit5.Text) Then  // if the directory exists then extract
      Begin
         FilesExtracted := UnZip1.Extract();
         ShowMessage('Files Extracted: ' + IntToStr(FilesExtracted));
      End
      Else
      Begin
         ShowMessage('Extract dir not defined');
         Exit;
      End;
   Finally
   	Working := False;
   End;
End;
//-------------------------------------------------------------

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

Procedure TfrmMain.FormCloseQuery(Sender: TObject; Var CanClose: Boolean);
Begin
   // activate .Cancel method incase user attempts to close the form
     // during the compression process.
   ZipSplitter1.Cancel := True;
   UnZip1.Cancel := True;
End;
//-------------------------------------------------------------

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

Procedure TfrmMain.BitBtn4Click(Sender: TObject);
Begin
	If Working Then Exit;
   Working := True;
   Try
      If ZipSplitter1.IsArcValid(ZipSplitter1.ArcType) Then
         frmTestArchive.ShowModal();
   Finally
   	Working := False;
   End;
End;
//-------------------------------------------------------------

(*
 ZipSplitter.OnBegin event
 Activated just prior to compiling each file
   *)

Procedure TfrmMain.ZipSplitter1Begin(Sender: TObject; FileName: String;
   Count: Integer; Var Extract: Boolean);
Begin
   ListBox1.Items.Add(FileName);
   StatusBar1.SimpleText := FileName;
End;
//-------------------------------------------------------------

(*
 ZipSplitter's OnDeactivate event
 Activated "after" compiling all files
   *)

Procedure TfrmMain.ZipSplitter1Deactivate(Sender: TObject);
Begin
   StatusBar1.SimpleText := '';
End;
//-------------------------------------------------------------

(*
 ZipSplitter.OnProgress event
 Activated during the compulation process
   *)

Procedure TfrmMain.ZipSplitter1Progress(Sender: TObject; ByFile, ByArchive: Byte);
Begin
   Gauge1.Progress := ByFile;
   Gauge2.Progress := ByArchive;
   Application.ProcessMessages();
End;
//-------------------------------------------------------------

(*
 UnZip.OnFileExists event
   *)

Procedure TfrmMain.UnZIP1FileExists(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;
//-------------------------------------------------------------

(*
 ZipSplitter.OnError event
   *)

Procedure TfrmMain.ZipSplitter1Error(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;
//-------------------------------------------------------------

(*
 ZipSplitter.OnGetPassword event
 *)

Procedure TfrmMain.ZipSplitter1GetPassword(Sender: TObject; FileName: String;
   Var Password: String; Var TryAgain: Boolean);
Begin
   //
End;
//-------------------------------------------------------------

(*
 ZipSplitter.OnSplitNewVolume event
 Activated when a new volume is opened for writing.

   In this demo, we use the NewVolumeName parameter to display the
   new volume in a StatusBar control.
   *)

Procedure TfrmMain.ZipSplitter1SplitNewVolume(Sender: TObject;
   Index: Cardinal; NewVolumeName: String);
Begin
   StatusBar1.SimpleText := 'Writing: ' + ExtractFilename(NewVolumeName);
   ListBox1.Items.Add('=====================');
   ListBox1.Items.Add('Created: ' + NewVolumeName);
End;
//-------------------------------------------------------------

(*
 Unzip.OnNextVolume event
   for archives containing multiple volumes, this event MUST be present.
   *)

Procedure TfrmMain.UnZip1NextVolume(Sender: TObject; Var VolumeName: String;
   VolumeID: Integer; FExists: Boolean; Var Cancel: Boolean);
Begin
   // if fExists equals true the volume was found.  If false, prompt
     // the user to locate the volume named in the VolumeID parameter.
   If (Not FExists) Then
      If MessageDlg('Insert disk containing ' + IntToStr(VolumeID) + ' then press OK',
         mtConfirmation,
         [mbOK, mbCancel], 0) = mrCancel Then
         Cancel := True;

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

(*
 ZipSplitter.OnFileScanStatus event

   Activated when the filescanner is searching for files matching
   the string values in the "FileSpec property".

   In this demo, we display the filenames being scanned.  This is so
   the user sees activativity... preventing a seemingly pause in the
   program.
   *)

Procedure TfrmMain.ZipSplitter1FileScanStatus(Sender: TObject;
   FileName: String; FilesCount: Integer; FilesSize: Int64);
Begin
   StatusBar1.SimpleText := IntToStr(FilesCount) + ' ' + FileName;
   StatusBar1.Update();
End;
//-------------------------------------------------------------

(*
 TZipSplitter.OnInsertDisk event
   If writing to removable disk (diskette) this event MUST be present.
   *)

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

(*
 ZipSplitter.OnNextVolume() event
   Activated just prior to opening a new zip volume.
   *)

Procedure TfrmMain.ZipSplitter1NextVolume(Sender: TObject;
   Var VolumeName: String; VolumeID: Integer; FExists: Boolean;
   Var Cancel: Boolean);
Var
   NewFile, Prompt, Caption: String;
Begin
   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;
End;
//-------------------------------------------------------------

// ZipSplitter1 - OnSplitDeleteVolume event

// Notes:
//
// 1.Activated after all volumes are written to disk.  All volumes
// whose numbers exceed the TotalVolumes for this archive are
// deleted.
//
// For example, test.zip already exists with volumes test.z01
// thru test.z99.  A new archive with the same name test.zip is
// created.  Except this time, there are only 10 output volumes
// were created.  All volumes whose name matches test.z11 thru
// test.z99 are deleted... activating this event once for each
// volume deleted.
//
// 2. DeleteToRecycleBin default = false.  If this value is false,
// the VolumeName is permanently deleted from disk.  True, the
// volume is deleted to the RecycleBin
//
// 3. If this event is not set, the excess volumes will be deleted
// to the RecycleBin.  The only way to permanently delete the
// volumes is to set this event, and change the DeleteToRecycleBin
// value to false.

Procedure TfrmMain.ZipSplitter1SplitDeleteVolume(Sender: TObject;
   VolumeName: String; Var DeleteToRecycleBin: Boolean);
Begin
   StatusBar1.SimpleText := 'Deleting: ' + ExtractFilename(VolumeName);
   ListBox1.Items.Add('=====================');
   ListBox1.Items.Add('Deleted: ' + VolumeName);
   DeleteToRecycleBin := True;
End;
//-------------------------------------------------------------

// OnSplitBegin event

// The minumum required size (MIN_CUST_SIZE) for a split archive
// is 65537.  If the archive is < MIN_CUST_SIZE, this event is
// bypassed

Procedure TfrmMain.ZipSplitter1SplitBegin(Sender: TObject; archive,
   TempFileName: String; Var Cancel: Boolean);
Begin
   Cancel := frmSplitArchive.ShowModal() = mrCancel;
End;
//-------------------------------------------------------------

Procedure TfrmMain.ZipSplitter1SplitEnd(Sender: TObject; VolumesCreated: Cardinal);
Begin
	ShowMessage('=OnSplitEnd Event=' + #13 + 'Volumes created:' + IntToStr(VolumesCreated));//
End;
//-------------------------------------------------------------

End.