mirrors/doublecmd
2
0
Fork 0
mirror of https://github.com/doublecmd/doublecmd.git synced 2026-06-21 09:58:13 +00:00
Code Issues Projects Releases Packages Wiki Activity

ADD: Extract files form

Browse source 
ADD: Packing in subdirectory
This commit is contained in:
Alexander Koblov 2007-08-04 18:56:34 +00:00
commit 9ffc2ce0de
14 changed files with 336 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

2
doc/fextractdlg.txt Normal file
View file

@ -0,0 +1,2 @@
$$$*** This is unit history file ***$$$ ###encoding="UTF-8"###
04.08.2007 Создал форму распаковки архивов

2
doc/fpackdlg.txt Normal file
View file

@ -0,0 +1,2 @@
$$$*** This is unit history file ***$$$ ###encoding="UTF-8"###
04.08.2007 Добавил обработку флагов упаковки

3
doc/uOSUtils.txt
View file

@ -3,4 +3,5 @@
16.07.2007 DEL: Перенес в uOSForms функцию, показывающую свойства файла
25.07.2007 ADD: Перенес из uCopyThread функцию FileCopyAttr (бывшая CorrectFileInfo), которая копирует
атрибуты файлов
01.08.2007 ADD: Добавил функции FileTimeToLocalFileTimeEx и FileTimeToDateTime
01.08.2007 ADD: Добавил функции FileTimeToLocalFileTimeEx и FileTimeToDateTime
04.08.2007 ADD: Добавил функции LocalFileTimeToFileTimeEx и DateTimeToFileTime

3
doc/uwcxmodule.txt
View file

@ -9,4 +9,5 @@
18.07.2007 Добавил обработку ChangeVolProc
20.07.2007 Добавил обработку ошибок, удалил старый неиспользуемый
больше код
30.07.2007 Добавил ProgressBar для операции удаления
30.07.2007 Добавил ProgressBar для операции удаления
04.08.2007 Добавил упаковку в подкаталоги, распаковку по маске

134
fextractdlg.lfm Normal file
View file

@ -0,0 +1,134 @@
object ExtractDlg: TExtractDlg
Tag = 1
Left = 309
Height = 168
Top = 176
Width = 400
HelpContext = 160
HorzScrollBar.Page = 399
VertScrollBar.Page = 167
ActiveControl = edtExtractTo
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Unpack files'
ClientHeight = 168
ClientWidth = 400
Font.Color = clBtnText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Position = poScreenCenter
object lblExtractTo: TLabel
Tag = 2
Left = 4
Height = 16
Top = 5
Width = 385
AutoSize = False
Caption = 'Unpack file to:'
ParentColor = False
end
object lblFileMask: TLabel
Tag = 3
Left = 4
Height = 16
Top = 51
Width = 129
AutoSize = False
Caption = '&Files to unpack:'
FocusControl = cbFileMask
ParentColor = False
end
object edtExtractTo: TEdit
Left = 4
Height = 21
Top = 26
Width = 385
Font.Height = -11
Font.Name = 'MS Sans Serif'
TabOrder = 0
end
object cbFileMask: TComboBox
Left = 134
Height = 21
Top = 49
Width = 255
AutoCompleteText = [cbactEndOfLineComplete, cbactSearchAscending]
Font.Height = -11
Font.Name = 'MS Sans Serif'
ItemHeight = 13
MaxLength = 0
TabOrder = 1
Text = '*.*'
end
object cbExtractPath: TCheckBox
Tag = 4
Left = 4
Height = 13
Top = 73
Width = 199
Caption = '&Unpack path names if stored with files'
TabOrder = 2
end
object cbOverwrite: TCheckBox
Tag = 5
Left = 4
Height = 13
Top = 92
Width = 124
Caption = '&Overwrite existing files'
TabOrder = 3
end
object btnOK: TButton
Tag = 4001
Left = 39
Height = 32
Top = 129
Width = 85
BorderSpacing.InnerBorder = 4
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 5
end
object btnTree: TButton
Tag = 6
Left = 128
Height = 32
Top = 129
Width = 85
BorderSpacing.InnerBorder = 4
Caption = '&Tree'
TabOrder = 6
end
object btnCancel: TButton
Tag = 4002
Left = 216
Height = 32
Top = 129
Width = 85
BorderSpacing.InnerBorder = 4
Cancel = True
Caption = 'Cancel'
ModalResult = 2
TabOrder = 7
end
object btnHelp: TButton
Tag = 4003
Left = 305
Height = 32
Top = 128
Width = 85
BorderSpacing.InnerBorder = 4
Caption = 'Help'
TabOrder = 8
end
object cbInSeparateFolder: TCheckBox
Tag = 7
Left = 4
Height = 13
Top = 111
Width = 322
Caption = 'Unpack each archive to a &separate subdir (name of the archive)'
TabOrder = 4
end
end

94
fextractdlg.pas Normal file
View file

@ -0,0 +1,94 @@
{
Double Commander
-------------------------------------------------------------------------
File unpacking window
Copyright (C) 2007 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 fExtractDlg;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, uVFS, uFileList;
type
{ TExtractDlg }
TExtractDlg = class(TForm)
lblExtractTo : TLabel;
edtExtractTo : TEdit;
lblFileMask : TLabel;
cbFileMask : TComboBox;
cbExtractPath : TCheckBox;
cbOverwrite : TCheckBox;
cbInSeparateFolder : TCheckBox;
btnOK : TButton;
btnTree : TButton;
btnCancel : TButton;
btnHelp : TButton;
private
{ private declarations }
public
{ public declarations }
end;
var
ExtractDlg: TExtractDlg;
procedure ShowExtractDlg(VFS : TVFS; var fl : TFileList; sDestPath:String);
implementation
var
CurrentVFS : TVFS;
procedure ShowExtractDlg(VFS : TVFS; var fl: TFileList; sDestPath: String);
var
I : Integer;
ExtractFileList : TFileList;
begin
with TExtractDlg.Create(nil) do
begin
edtExtractTo.Text := sDestPath;
CurrentVFS := VFS;
if (ShowModal = mrOK) then
begin
sDestPath := IncludeTrailingPathDelimiter(edtExtractTo.Text) + cbFileMask.Text;
ExtractFileList := TFileList.Create;
ExtractFileList.CurrentDirectory := PathDelim;
for I := 0 to fl.Count - 1 do
if VFS.FindModule(fl.GetFileName(I)) then
begin
VFS.VFSmodule.VFSList(PathDelim, ExtractFileList); // select all files
VFS.VFSmodule.VFSCopyOutEx(ExtractFileList, sDestPath, 0);
end;
end;
Free;
end;
end;
initialization
{$I fextractdlg.lrs}
end.

27
fmain.lfm
View file

@ -1,14 +1,14 @@
inherited frmMain: TfrmMain
Left = 189
Left = 241
Height = 336
Top = 178
Top = 177
Width = 525
HorzScrollBar.Page = 524
VertScrollBar.Page = 315
VertScrollBar.Page = 316
VertScrollBar.Range = 79
ActiveControl = pnlNotebooks
Caption = 'Double Commander'
ClientHeight = 316
ClientHeight = 317
ClientWidth = 525
Font.Color = clBlack
Font.Height = 13
@ -97,7 +97,7 @@ inherited frmMain: TfrmMain
end
object pnlCommand: TPanel
Height = 62
Top = 254
Top = 255
Width = 525
Align = alBottom
Anchors = [akLeft, akRight]
@ -227,18 +227,18 @@ inherited frmMain: TfrmMain
end
end
object pnlNotebooks: TPanel
Height = 185
Height = 186
Top = 69
Width = 525
Align = alClient
ClientHeight = 185
ClientHeight = 186
ClientWidth = 525
FullRepaint = False
TabOrder = 3
TabStop = True
object nbLeft: TNotebook
Left = 1
Height = 183
Height = 184
Top = 1
Width = 391
Align = alLeft
@ -248,14 +248,14 @@ inherited frmMain: TfrmMain
end
object Splitter1: TSplitter
Left = 392
Height = 183
Height = 184
Top = 1
Width = 4
ResizeStyle = rsLine
end
object nbRight: TNotebook
Left = 396
Height = 183
Height = 184
Top = 1
Width = 128
Align = alClient
@ -786,6 +786,13 @@ inherited frmMain: TfrmMain
OnExecute = actPackFilesExecute
ShortCut = 32884
end
object actExtractFiles: TAction
Category = 'File'
Caption = 'Extract files'
DisableIfNoHandler = True
OnExecute = actExtractFilesExecute
ShortCut = 32888
end
end
object pmHotList: TPopupMenu
left = 152

30
fmain.pas
View file

@ -54,6 +54,7 @@ type
TfrmMain = class(TfrmLng)
actChMod: TAction;
actChown: TAction;
actExtractFiles: TAction;
actPackFiles: TAction;
actRemoveTab: TAction;
actNewTab: TAction;
@ -176,6 +177,7 @@ type
actFileSpliter: TAction;
pmToolBar: TPopupMenu;
Splitter1: TSplitter;
procedure actExtractFilesExecute(Sender: TObject);
procedure actPackFilesExecute(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
@ -309,7 +311,7 @@ uses
uCopyThread, uFileList, uDeleteThread,
fMkDir, fCopyDlg, fCompareFiles,{ fEditor,} fMoveDlg, uMoveThread, uShowMsg,
fFindDlg, uSpaceThread, fHotDir, fSymLink, fHardLink,
fMultiRename, uShowForm, uGlobsPaths, fFileOpDlg, fMsg, fPackDlg,
fMultiRename, uShowForm, uGlobsPaths, fFileOpDlg, fMsg, fPackDlg, fExtractDlg,
fLinker, fSplitter, uFileProcs, lclType, LCLProc, uOSUtils, uOSForms, uPixMapManager;
@ -354,6 +356,28 @@ begin
end;
procedure TfrmMain.actExtractFilesExecute(Sender: TObject);
var
fl : TFileList;
begin
fl:=TFileList.Create;
with ActiveFrame do
begin
SelectFileIfNoSelected(GetActiveItem);
CopyListSelectedExpandNames(pnlFile.FileList,fl,ActiveDir);
fl.CurrentDirectory := ActiveDir;
end;
try
ShowExtractDlg(ActiveFrame.pnlFile.VFS, fl, NotActiveFrame.ActiveDir);
finally
frameLeft.RefreshPanel;
frameRight.RefreshPanel;
end;
end;
procedure TfrmMain.Button2Click(Sender: TObject);
begin
end;
@ -552,14 +576,14 @@ begin
{Left panel}
LastDir := gIni.ReadString('left', 'path', '');
if LastDir <> '' then
if (LastDir <> '') and (DirectoryExists(LastDir)) then
begin
FrameLeft.pnlFile.ActiveDir := LastDir;
FrameLeft.pnlFile.LoadPanel;
end;
{Right panel}
LastDir := gIni.ReadString('right', 'path', '');
if LastDir <> '' then
if (LastDir <> '') and (DirectoryExists(LastDir)) then
begin
FrameRight.pnlFile.ActiveDir := LastDir;
FrameRight.pnlFile.LoadPanel;

4
fpackdlg.lfm
View file

@ -25,7 +25,6 @@ object PackDlg: TPackDlg
Width = 445
AutoSize = False
Caption = 'Pack file(s) to the file:'
Color = clNone
Font.Color = clBtnText
Font.Height = -11
Font.Name = 'MS Sans Serif'
@ -49,7 +48,6 @@ object PackDlg: TPackDlg
Width = 197
Caption = 'Also &pack path names (only recursed)'
Checked = True
Enabled = False
State = cbChecked
TabOrder = 1
end
@ -167,7 +165,6 @@ object PackDlg: TPackDlg
Top = 91
Width = 97
Caption = 'M&ove to archive'
Enabled = False
TabOrder = 4
end
object cbCreateSFX: TCheckBox
@ -197,7 +194,6 @@ object PackDlg: TPackDlg
Top = 139
Width = 56
Caption = 'Encr&ypt'
Enabled = False
TabOrder = 7
end
object cbCreateSeparateArchives: TCheckBox

8
fpackdlg.pas
View file

@ -75,6 +75,8 @@ var
CurrentVFS : TVFS;
procedure ShowPackFilesForm(VFS : TVFS; var fl: TFileList; sDestPath:String);
var
Flags : LongInt;
begin
with TPackDlg.Create(nil) do
begin
@ -93,7 +95,11 @@ begin
if (ShowModal = mrOK) then
if VFS.FindModule(edtPackCmd.Text) then
begin
VFS.VFSmodule.VFSCopyIn(fl, '', 2);
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;
VFS.VFSmodule.VFSCopyIn(fl, '', Flags);
end;
Free;
end;

19
uOSUtils.pas
View file

@ -84,7 +84,9 @@ function GetAllDrives : TList;
(* Date/Time routines *)
function FileTimeToLocalFileTimeEx(const lpFileTime: TFileTime; var lpLocalFileTime: TFileTime): LongBool;
function LocalFileTimeToFileTimeEx(const lpLocalFileTime: TFileTime; var lpFileTime: TFileTime): LongBool;
function FileTimeToDateTime(ft : TFileTime) : TDateTime;
function DateTimeToFileTime(dt : TDateTime) : TFileTime;
implementation
@ -513,10 +515,27 @@ begin
end;
{$ENDIF}
function LocalFileTimeToFileTimeEx(const lpLocalFileTime: TFileTime; var lpFileTime: TFileTime): LongBool;
{$IFDEF MSWINDOWS}
begin
Result := LocalFileTimeToFileTime(lpLocalFileTime, lpFileTime);
end;
{$ELSE}
begin
Int64(lpFileTime) := Int64(lpLocalFileTime) - 10000000 * Int64(TZSeconds);
end;
{$ENDIF}
function FileTimeToDateTime(ft : TFileTime) : TDateTime;
begin
FileTimeToLocalFileTimeEx(ft,ft);
Result := (Int64(ft) / 864000000000.0) - 109205.0;
end;
function DateTimeToFileTime(dt : TDateTime) : TFileTime;
begin
Int64(Result) := Round((dt + 109205.0) * 864000000000.0);
LocalFileTimeToFileTimeEx(Result, Result);
end;
end.

2
udcutils.pas
View file

@ -9,7 +9,7 @@ Several useful functions
contributors:
Radek Cervinka <radek.cervinka@centrum.cz>
Part of this code got from http://www.delphirus.com.ru
Part of this code based on code from http://www.delphirus.com.ru
}

35
uwcxmodule.pas
View file

@ -55,6 +55,7 @@ Type
private
FArcFileList : TList;
FFileList : TFileList;
FFileMask : String;
FFlags : Integer;
FDstPath,
fFolder : String;
@ -456,7 +457,10 @@ var
begin
FPercent := 0;
FFileMask := ExtractFileName(FDstPath);
if FFileMask = '' then FFileMask := '*'; // extract all selected files/folders
FDstPath := ExtractFilePath(FDstPath);
(* Get current folder in archive *)
Folder := FFileList.CurrentDirectory; //LowDirLevel(FFileList.GetItem(0)^.sName);
@ -532,13 +536,22 @@ end;
function TWCXModule.WCXCopyIn : Boolean;
var
FileList, Folder : PChar;
FileList, Folder, pDstPath : PChar;
I : Integer;
begin
DebugLN('VFSCopyIn =' + FArchiveName);
FPercent := 0;
New(FileList);
New(Folder);
FDstPath := ExtractDirLevel(FArchiveName + PathDelim, FDstPath);
FDstPath := ExcludeTrailingPathDelimiter(FDstPath);
if FDstPath = '' then
pDstPath := nil
else
pDstPath := PChar(FDstPath);
DebugLN('sDstPath == ' + FDstPath);
(* Add in file list files from subfolders *)
FillAndCount(FFileList, FFilesSize);
@ -553,7 +566,7 @@ begin
SetChangeVolProc(0, ChangeVolProc);
SetProcessDataProc(0, ProcessDataProc);
iResult := PackFiles(PChar(FArchiveName), nil{PChar(FDstPath)}, Folder, FileList, FFlags);
iResult := PackFiles(PChar(FArchiveName), pDstPath, Folder, FileList, FFlags);
// Check for errors
if iResult <> 0 then
@ -570,10 +583,10 @@ procedure TWCXModule.CopySelectedWithSubFolders(var flist:TFileList);
fr : PFileRecItem;
I, Count : Integer;
CurrFileName : String; // Current file name
bForceDirectory : Boolean; // for future
begin
ForceDirectory(FDstPath + ExtractDirLevel(FFolder, PathDelim + sDir));
bForceDirectory := True;
//DebugLN('ForceDirectory = ' + FDstPath + ExtractDirLevel(FFolder, PathDelim + sDir));
@ -587,9 +600,14 @@ procedure TWCXModule.CopySelectedWithSubFolders(var flist:TFileList);
if not IncludeFileInList(sDir + PathDelim, CurrFileName) then
Continue;
if not(G_ValidateWildText(CurrFileName, FFileMask)
or FPS_ISDIR(PHeaderData(FArcFileList.Items[I])^.FileAttr)) then
Continue;
// DebugLN('In folder = ' + CurrFileName);
if bForceDirectory then
ForceDirectory(FDstPath + ExtractDirLevel(FFolder, PathDelim + sDir));
New(fr);
with fr^, PHeaderData(FArcFileList.Items[I])^ do
begin
@ -629,6 +647,9 @@ begin
if fri.sName[1] = PathDelim then
Delete(fri.sName, 1, 1);
if not(G_ValidateWildText(fri.sName, FFileMask) or FPS_ISDIR(fri.iMode)) then
Continue;
Newfl.AddItem(@fri);
DebugLN('Curr File = ' + fri.sName);
@ -639,7 +660,7 @@ begin
inc(FFilesSize, fri.iSize);
end;
end;
end; //for
FreeAndNil(flist);
flist := Newfl;
end;

2
uwfxmodule.pas
View file

@ -442,7 +442,7 @@ begin
iInt64Rec.Value := iSize;
SizeLow := iInt64Rec.Low;
SizeHigh := iInt64Rec.High;
//LastWriteTime := fTimeI;
LastWriteTime := DateTimeToFileTime(fTimeI);
Attr := iMode;
end;