{ Double Commander ------------------------------------------------------------------------- File packing window Copyright (C) 2007-2008 Koblov Alexander (Alexx2000@mail.ru) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA } unit fPackDlg; {$mode objfpc}{$H+} interface uses Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, Buttons, uFileList, uVFS, EditBtn, ExtCtrls; type { TfrmPackDlg } TfrmPackDlg = class(TForm) btnConfig: TButton; btnHelp: TButton; btnCancel: TButton; cbCreateSeparateArchives: TCheckBox; cbCreateSFX: TCheckBox; cbEncrypt: TCheckBox; cbMoveToArchive: TCheckBox; cbMultivolume: TCheckBox; btnOk: TButton; cbPackerList: TComboBox; cbOtherPlugins: TCheckBox; edtPackCmd: TDirectoryEdit; lblPrompt: TLabel; cbRecurse: TCheckBox; cbStoredir: TCheckBox; rgPacker: TRadioGroup; procedure btnConfigClick(Sender: TObject); procedure cbOtherPluginsChange(Sender: TObject); procedure edtPackCmdAcceptDirectory(Sender: TObject; var Value: String); procedure FormShow(Sender: TObject); procedure arbChange(Sender: TObject); private CurrentVFS : TVFS; public { public declarations } end; function ShowPackDlg(VFS : TVFS; var fl : TFileList; sDestPath:String; bNewArchive : Boolean = True): Boolean; implementation uses uWCXhead, uGlobs; function ShowPackDlg(VFS : TVFS; var fl: TFileList; sDestPath:String; bNewArchive : Boolean = True): Boolean; var Flags : LongInt; begin with TfrmPackDlg.Create(nil) do begin if bNewArchive then // create new archive (* if one file selected *) if fl.Count = 1 then begin edtPackCmd.Text := sDestPath + ExtractFileName(fl.GetFileName(0)); edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, '.none'); end else (* if some files selected *) begin edtPackCmd.Text := sDestPath + ExtractFileName(ExcludeTrailingPathDelimiter(fl.CurrentDirectory)) + '.none'; end else // pack in exsists archive edtPackCmd.Text := VFS.ArcFullName; CurrentVFS := VFS; Result:= (ShowModal = mrOK); if Result then if VFS.FindModule(edtPackCmd.Text, False) then begin Flags := 0; if cbMoveToArchive.Checked then Flags := Flags or PK_PACK_MOVE_FILES; if cbStoredir.Checked then Flags := Flags or PK_PACK_SAVE_PATHS; if cbEncrypt.Checked then Flags := Flags or PK_PACK_ENCRYPT; if bNewArchive then begin VFS.LoadAndOpen(edtPackCmd.Text, False); VFS.VFSmodule.VFSCopyIn(fl, '', Flags) end else begin VFS.LoadAndOpen(edtPackCmd.Text, True); VFS.VFSmodule.VFSCopyIn(fl, sDestPath, Flags) end; end; Free; end; end; { TfrmPackDlg } procedure TfrmPackDlg.FormShow(Sender: TObject); var iIndex, I, J : Integer; bExsistArchive : Boolean; sExt, sCurrentPlugin : String; iCurPlugCaps : Integer; Count : Integer; begin J := 0; Count := 0; sExt := ExtractFileExt(edtPackCmd.Text); Delete(sExt, 1, 1); // delete a dot bExsistArchive := (sExt <> 'none'); with CurrentVFS do begin for I:=0 to gWCXPlugins.Count - 1 do begin if Pos('#', gWCXPlugins.Names[I]) <> 0 then Continue; sCurrentPlugin := gWCXPlugins.ValueFromIndex[i]; iCurPlugCaps := StrToInt(Copy(sCurrentPlugin, 1, Pos(',',sCurrentPlugin) - 1)); if (iCurPlugCaps and PK_CAPS_NEW) = PK_CAPS_NEW then begin (* First 9 plugins we display as RadioButtons *) if J < 9 then begin iIndex := rgPacker.Items.Add(gWCXPlugins.Names[I]); if bExsistArchive then if (sExt = gWCXPlugins.Names[I]) then rgPacker.ItemIndex := iIndex else rgPacker.Controls[iIndex + 1].Enabled := False; J := J + 1; end else (* Other plugins we add in ComboBox *) begin iIndex := cbPackerList.Items.Add(gWCXPlugins.Names[I]); if bExsistArchive and (sExt = gWCXPlugins.Names[I]) then cbPackerList.ItemIndex := iIndex; end; end; end; //for if (rgPacker.Items.Count > 0) and (rgPacker.ItemIndex < 0) then rgPacker.ItemIndex := 0; if cbPackerList.Items.Count > 0 then begin cbOtherPlugins.Visible := True; cbPackerList.Visible := True; if bExsistArchive then cbPackerList.Enabled:= False else cbOtherPlugins.Enabled := True; if cbPackerList.ItemIndex < 0 then cbPackerList.ItemIndex := 0; end else btnConfig.AnchorToCompanion(akTop, 6, rgPacker); end; end; procedure TfrmPackDlg.btnConfigClick(Sender: TObject); begin with CurrentVFS do if FindModule(edtPackCmd.Text, False) and LoadAndOpen(edtPackCmd.Text, False) then VFSmodule.VFSConfigure(Handle); end; procedure TfrmPackDlg.cbOtherPluginsChange(Sender: TObject); begin if cbOtherPlugins.Checked then begin edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, '.' + cbPackerList.Text); rgPacker.ItemIndex := -1; end else begin if rgPacker.ItemIndex = -1 then rgPacker.ItemIndex := 0; end; cbPackerList.Enabled := cbOtherPlugins.Checked; end; procedure TfrmPackDlg.edtPackCmdAcceptDirectory(Sender: TObject; var Value: String ); begin Value := IncludeTrailingPathDelimiter(Value) + ExtractFileName(edtPackCmd.Text); end; procedure TfrmPackDlg.arbChange(Sender: TObject); begin if rgPacker.ItemIndex >= 0 then begin edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, '.' + rgPacker.Items[rgPacker.ItemIndex]); cbOtherPlugins.Checked := False; end; end; initialization {$I fpackdlg.lrs} end.