arch1.pas

用于Delphi和BCB的高速压缩组件库

   begin
    FileListBox1.Tag:=1; //flag -1-archive is open, 0-archive is not open
    ShowArchiveContent(FileListBox1.FileName);
   end;
 //if not - run associated program
 if FileListBox1.Tag<>1 then
  ShellExecute(Handle,'Open',
              pchar(FileListBox1.FileName),nil,nil,SW_SHOWNORMAL);
end; // TMainForm.FileListBox1DblClick

//------------------------------------------------------------------------------
//Show 'Add files' window
//------------------------------------------------------------------------------
procedure TMainForm.AAddExecute(Sender: TObject);
begin
 NewArc := False;
 frmAdd.ShowModal;
end; // TMainForm.AAddExecute

//------------------------------------------------------------------------------
//Show 'Extract files' window
//------------------------------------------------------------------------------
procedure TMainForm.AExtractExecute(Sender: TObject);
var i:integer;
begin
 frmExtract.ShowModal;
 //Create list with selected items for extract
 for i:=0 to (FileListBox1.Items.Count-1) do
  FileListBox1.Selected[i]:=false;
end; // TMainForm.AExtractExecute

//------------------------------------------------------------------------------
//Open archive dialog
//------------------------------------------------------------------------------
procedure TMainForm.AOpenExecute(Sender: TObject);
begin
 if OpenDialog1.Execute then
  begin
   FileListBox1.Tag:=1;
   ShowArchiveContent(OpenDialog1.FileName);
  end;
end; // TMainForm.AOpenExecute

//------------------------------------------------------------------------------
//Some variables initialization
//------------------------------------------------------------------------------
procedure TMainForm.FormCreate(Sender: TObject);
begin
 FileList := TStringList.Create;
 UpdList := TStringList.Create;
 DirectoryListBox1.MultiSelect := true;
 CurrentDir := FileListBox1.Directory;
 Updates(FileListBox1.Tag);
 {$IFDEF FC}
 Archiver := TFlexCompress.Create(MainForm);
 MainForm.Caption := 'FlexCompress archiver';
 OpenDialog1.Filter := 'FlexCompress archives (*.fxc)|*.FXC|All Files (*.*)|*.*';
 {$ENDIF}
 {$IFDEF ZF}
 Archiver := TZipForge.Create(MainForm);
 MainForm.Caption := 'ZipForge archiver';
 OpenDialog1.Filter := 'ZipForge archives (*.zip)|*.ZIP|All Files (*.*)|*.*';
 {$ENDIF}
 {$IFDEF ZF_int}
 Archiver := TZipForge.Create(MainForm);
 MainForm.Caption := 'ZipForge archiver';
 OpenDialog1.Filter := 'ZipForge archives (*.zip)|*.ZIP|All Files (*.*)|*.*';
 {$ENDIF}
 Archiver.OnOverallProgress := ArchiverOverallProgress;
 Archiver.OnFileProgress := ArchiverFileProgress;
 Archiver.OnProcessFileFailure := ArchiverProcessFileFailure;
end; // TMainForm.FormCreate

//------------------------------------------------------------------------------
//Update path to file
//------------------------------------------------------------------------------
procedure TMainForm.FileListBox1Change(Sender: TObject);
begin
 CurrentDir := FileListBox1.Directory;
 Label1.Text := '';
if FileListBox1.Tag=1 then  // if archive is opened
  Label1.Text := ArcName+'/'+FileListBox1.Items[FileListBox1.ItemIndex]
else //no archive
 if FileListBox1.FileName='' then //Empty directory
  Label1.Text := DirectoryListBox1.Directory
 else
  Label1.Text := FileListBox1.FileName;
end; // TMainForm.FileListBox1Change

//------------------------------------------------------------------------------
//Closes opened archive
//------------------------------------------------------------------------------
procedure TMainForm.ACloseExecute(Sender: TObject);
begin
 FileListBox1.Left := 232;
 mComment.Hide;
 Label4.Show;
 DirectoryListBox1.Show;
 DriveComboBox1.Show;
 FileListBox1.Tag := 0;
 Updates(FileListBox1.Tag);
 AAdd.Enabled := true;
 AExtract.Enabled := false;
 AUpdate.Enabled := false;
 AClose.Enabled := false;
 ANew.Enabled := true;
 Label3.Caption := 'Select directory:';
 Label2.Caption := 'Select file:';
end; // TMainForm.ACloseExecute

{$IFDEF FC}

//------------------------------------------------------------------------------
//Show progress of compressing file
//------------------------------------------------------------------------------
procedure TMainForm.ArchiverFileProgress(Sender: TObject; FileName: String;
  Progress: Double; Operation: TFXCProcessOperation;
  ProgressPhase: TFXCProgressPhase; var Cancel: Boolean);
begin
 frmProgress.gFile.Progress := Round(Progress);
 frmProgress.lbFile.Caption := FileName;
 Cancel := frmProgress.bCancel;
 Application.ProcessMessages;
end; // TMainForm.ArchiverFileProgress

//------------------------------------------------------------------------------
//Show progress of compressing all files
//------------------------------------------------------------------------------
procedure TMainForm.ArchiverOverallProgress(Sender: TObject;
  Progress: Double; Operation: TFXCProcessOperation;
  ProgressPhase: TFXCProgressPhase; var Cancel: Boolean);
begin
 if (ProgressPhase = ppStart) then
  frmProgress.Show
 else
 if (ProgressPhase = ppEnd) then
  frmProgress.Hide;

 frmProgress.gOverall.Progress := Round(Progress);
 Cancel := frmProgress.bCancel;
 Application.ProcessMessages;
end; // TMainForm.ArchiverOverallProgress

//------------------------------------------------------------------------------
//Errors in operations with files
//------------------------------------------------------------------------------
procedure TMainForm.ArchiverProcessFileFailure(Sender: TObject;
  FileName: String; Operation: TFXCProcessOperation; NativeError:	Integer;
  ErrorCode: Integer; ErrorMessage: String; var Action: TFXCAction);
begin
 Action := fxaIgnore;
 MessageDlg('Native error: '+ inttostr(NativeError)+ #13#10 +
 ErrorMessage + #13#10 + filename, mtError, [mbOk], 0)
end;

{$ENDIF}

{$IFDEF ZF_int}

//------------------------------------------------------------------------------
//Show progress of compressing file
//------------------------------------------------------------------------------
procedure TMainForm.ArchiverFileProgress(Sender: TObject; FileName: String;
  Progress: Double; Operation: TFXCProcessOperation;
  ProgressPhase: TFXCProgressPhase; var Cancel: Boolean);
begin
 frmProgress.gFile.Progress := Round(Progress);
 frmProgress.lbFile.Caption := FileName;
 Cancel := frmProgress.bCancel;
 Application.ProcessMessages;
end; // TMainForm.ArchiverFileProgress

//------------------------------------------------------------------------------
//Show progress of compressing all files
//------------------------------------------------------------------------------
procedure TMainForm.ArchiverOverallProgress(Sender: TObject;
  Progress: Double; Operation: TFXCProcessOperation;
  ProgressPhase: TFXCProgressPhase; var Cancel: Boolean);
begin
 if (ProgressPhase = ppStart) then
  frmProgress.Show
 else
 if (ProgressPhase = ppEnd) then
  frmProgress.Hide;

 frmProgress.gOverall.Progress := Round(Progress);
 Cancel := frmProgress.bCancel;
 Application.ProcessMessages;
end; // TMainForm.ArchiverOverallProgress

//------------------------------------------------------------------------------
//Errors in operations with files
//------------------------------------------------------------------------------
procedure TMainForm.ArchiverProcessFileFailure(Sender: TObject;
  FileName: String; Operation: TFXCProcessOperation; NativeError:	Integer;
  ErrorCode: Integer; ErrorMessage: String; var Action: TFXCAction);
begin
 Action := fxaIgnore;
 MessageDlg('Native error: '+ inttostr(NativeError)+ #13#10 +
 ErrorMessage + #13#10 + filename, mtError, [mbOk], 0)
end;

{$ENDIF}

{$IFDEF ZF}

//------------------------------------------------------------------------------
//Show progress of compressing file
//------------------------------------------------------------------------------
procedure TMainForm.ArchiverFileProgress(Sender: TObject; FileName: String;
  Progress: Double; Operation: TZFProcessOperation;
  ProgressPhase: TZFProgressPhase; var Cancel: Boolean);
begin
 frmProgress.gFile.Progress := Round(Progress);
 frmProgress.lbFile.Caption := FileName;
 Cancel := frmProgress.bCancel;
 Application.ProcessMessages;
end; // TMainForm.ArchiverFileProgress

//------------------------------------------------------------------------------
//Show progress of compressing all files
//------------------------------------------------------------------------------
procedure TMainForm.ArchiverOverallProgress(Sender: TObject;
  Progress: Double; Operation: TZFProcessOperation;
  ProgressPhase: TZFProgressPhase; var Cancel: Boolean);
begin
 if (ProgressPhase = ppStart) then
  frmProgress.Show
 else
 if (ProgressPhase = ppEnd) then
  frmProgress.Hide;

 frmProgress.gOverall.Progress := Round(Progress);
 Cancel := frmProgress.bCancel;
 Application.ProcessMessages;
end; // TMainForm.ArchiverOverallProgress

//------------------------------------------------------------------------------
//Errors in operations with files
//------------------------------------------------------------------------------
procedure TMainForm.ArchiverProcessFileFailure(Sender: TObject;
  FileName: String; Operation: TZFProcessOperation; NativeError:	Integer;
  ErrorCode: Integer; ErrorMessage: String; var Action: TZFAction);
begin
 Action := fxaIgnore;
 MessageDlg('Native error: '+ inttostr(NativeError)+ #13#10 +
 ErrorMessage + #13#10 + filename, mtError, [mbOk], 0)
end;

{$ENDIF}

//------------------------------------------------------------------------------
//Return Focus to the frmProgress if it's active
//------------------------------------------------------------------------------
procedure TMainForm.FormActivate(Sender: TObject);
begin
 if frmProgress.Visible then frmProgress.SetFocus;
end; // TMainForm.FormActivate

//------------------------------------------------------------------------------
//Update opened archive
//------------------------------------------------------------------------------
procedure TMainForm.AUpdateExecute(Sender: TObject);
var i:integer;
begin
 OpenDialog1.Options := [ofAllowMultiSelect]; //turn on multi-select
 if OpenDialog1.Execute then
  UpdList.AddStrings(OpenDialog1.Files); //add selected files to UpdList
   Archiver.FileMasks.Clear;
   Archiver.BaseDir := ExtractFilePath(UpdList.Strings[0]);
   for i:=0 to (OpenDialog1.Files.Count-1) do
    Archiver.FileMasks.Add(ExtractFileName(UpdList.Strings[i])); //add UpdList to FileMasks
   Archiver.FileName := ArcName;
   try
    Archiver.OpenArchive(fmOpenReadWrite);
   except
    MessageDlg('Can''t open archive', mtError, [mbOk], 0)
   end;
   Archiver.UpdateFiles; //Update archive
   try
    Archiver.CloseArchive;
   except
    MessageDlg('Can''t close archive', mtError, [mbOk], 0)
   end;
end; // TMainForm.AUpdateExecute

//------------------------------------------------------------------------------
//Select directory when PopupMenu is shown
//------------------------------------------------------------------------------
procedure TMainForm.DirectoryListBox1ContextPopup(Sender: TObject;
  MousePos: TPoint; var Handled: Boolean);
var
 exist:boolean;
 i:integer;
begin
 for i := 0 to (DirectoryListBox1.Items.Count - 1) do
  if DirectoryListBox1.Selected[i] then
   DirectoryListBox1.Selected[i] := false;
 DirectoryListBox1.Selected[DirectoryListBox1.ItemAtPos(MousePos,exist)] := true;
end; // TMainForm.DirectoryListBox1ContextPopup

procedure TMainForm.ANewExecute(Sender: TObject);
begin
 NewArc := True;
 frmAdd.btnBrowseClick(nil);
end;

end.