Groesz.org
/
rsvk
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
rsvk/Archiver Demo/main.pas

2024 lines
62 KiB
Plaintext
Raw Blame History

unit main;
{-------------------------------------------------------------------------------
Main Form
---------
the main interface.
---------------------------------------------
reSource v2.61
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
IMPORTANT:
To learn how to use the component TResource, open the unit ResourceCompUnit.
There is a detailed description of how to perform Archive Actions.
This unit, main, implements the descriptions in a full featured archiver.
Desc:
This is the interface portion to ArchiveManager.
The MainForm show a file list, speed buttons, a status/hint bar and a main menu.
The user
- 'sees' the archive from here - what is inside the archive and the file
properties.
- performs operations on the archive - add, delete or extract files. File
properties can also be changed (right click on the FileList)
Changes:
Version 2.61: (15/10)
- fixed a bug in the GetCompressionRatio function which caused the calculation
overflow when calculating for larger files. (credits: Richard Sutcliffe)
-------------------------------------------------------------------------------}
(**) interface (**)
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Gauges, ComCtrls, ExtCtrls, Menus, Buttons, ToolWin, ShellApi,
CommCtrl, ActnList, activex, FileCtrl, Contnrs,
// engine - include in your app to access TCentralFileHeader etc.
// your search path must contain the dir the units are located in.
ResourceCompUnit,
ArchiveHeadersUnit, ErrorUnit, EDosUnit, ArchiveManagerUnit, StructsUnit;
procedure CentreFormToMain(form: TForm);
const
LogLinesLimit = 10000;
type
TMainForm = class(TForm)
OpenDialog2: TOpenDialog;
File1: TMenuItem;
MIExit: TMenuItem;
N2: TMenuItem;
MIOpen: TMenuItem;
MIClose: TMenuItem;
Help1: TMenuItem;
MIAbout: TMenuItem;
View1: TMenuItem;
MIConfiguration: TMenuItem;
FileListPopup: TPopupMenu;
MIProperties: TMenuItem;
Actions1: TMenuItem;
MISelectAll: TMenuItem;
N1: TMenuItem;
MIAdd: TMenuItem;
MIExtract: TMenuItem;
MIDelete: TMenuItem;
MICompressionStats: TMenuItem;
miProgStats: TMenuItem;
StatusBar: TStatusBar;
MainMenu: TPopupMenu;
ActionList: TActionList;
SelectAllAct: TAction;
OpenDialog: TOpenDialog;
AddSelectFilesAct: TAction;
ExtractSelFilesAct: TAction;
DelSelFilesAct: TAction;
SetPropertyAct: TAction;
Properties1: TMenuItem;
OpenAct: TAction;
CreateNewAct: TAction;
CloseAct: TAction;
CreateNew1: TMenuItem;
ControlBar1: TControlBar;
ToolBarPanel: TPanel;
OpenBtn: TSpeedButton;
AddBtn: TSpeedButton;
ExtractBtn: TSpeedButton;
DeleteBtn: TSpeedButton;
SpeedButton1: TSpeedButton;
SpeedButton2: TSpeedButton;
CompressBtn: TButton;
DecompressBtn: TButton;
MenuToolBar: TToolBar;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
ToolButton3: TToolButton;
ToolButton4: TToolButton;
FileList: TListView;
Splitter1: TSplitter;
RichEdit: TRichEdit;
Resource1: TResource;
procedure CompressBtnClick(Sender: TObject);
procedure DecompressBtnClick(Sender: TObject);
procedure ExitBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FileListChange(Sender: TObject; Item: TListItem;
Change: TItemChange);
procedure MIAboutClick(Sender: TObject);
procedure MIConfigurationClick(Sender: TObject);
procedure MIPropertiesClick(Sender: TObject);
procedure FileListDblClick(Sender: TObject);
procedure MIDeleteClick(Sender: TObject);
procedure MISelectAllClick(Sender: TObject);
procedure MIDeselectAllClick(Sender: TObject);
procedure FileListColumnClick(Sender: TObject; Column: TListColumn);
procedure FileListPopupPopup(Sender: TObject);
procedure MIExitClick(Sender: TObject);
procedure MICompressionStatsClick(Sender: TObject);
procedure miProgStatsClick(Sender: TObject);
procedure Chart1Click(Sender: TObject);
procedure FileListSelectItem(Sender: TObject; Item: TListItem;
Selected: Boolean);
{procedure FileListMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);}
{procedure FileListData(Sender: TObject; Item: TListItem);
procedure FileListDataHint(Sender: TObject; StartIndex,
EndIndex: Integer);}
procedure Test(Sender: TObject);
procedure SelectAllActExecute(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
procedure Resource1CentralDirChange(Sender: TObject);
procedure AddSelectFilesActExecute(Sender: TObject);
procedure ExtractSelFilesActExecute(Sender: TObject);
procedure DelSelFilesActExecute(Sender: TObject);
procedure SetPropertyActExecute(Sender: TObject);
procedure SetPropertyActUpdate(Sender: TObject);
procedure OpenActExecute(Sender: TObject);
procedure CreateNewActExecute(Sender: TObject);
procedure CloseActExecute(Sender: TObject);
procedure DelSelFilesActUpdate(Sender: TObject);
procedure SelectAllActUpdate(Sender: TObject);
procedure Resource1AddLog(Sender: TObject; s: String);
procedure Button1Click(Sender: TObject);
private
TotalSelFileSize: integer; // calculation of selected file size
ColMan: TObjectList; // manages the columns for FileList
{DropSource: TDropFileSource;}
// message handlers
procedure WMMove(var m: TMessage); message WM_MOVE;
procedure WMDropFiles(var msg : TMessage); message WM_DROPFILES;
procedure EnableArchiveActions(const Enable: boolean);
procedure EnableFileListSensitiveItems(const Enable: boolean);
// event handlers
{procedure DropSourceDrop(Sender: TObject; DragType: TDragType;
var ContinueDrop: Boolean);}
// wrapper functions of ArchiveManager
procedure OpenArchive(const filename: string; const create_new_prompt: boolean);
procedure CloseArchive;
// misc
//procedure DisplayHint(Sender: TObject);
procedure GenerateColumns;
function IsSortedAscending(Column: TListColumn): boolean;
// filelist
procedure GetSelFilesList(list: TList);
//procedure CacheFileInfo(const startindex, endindex: integer);
public
procedure AddLog(s: string; Color: TColor = clWindowText; Style: TFontStyles = []);
// status support (status bar, progress bar)
procedure ShowStatusMessage(const s: string);
function GetNumFilesStr(const num: integer): string;
procedure ShowProgress(const num: integer);
// application status. involves the screen cursor
procedure ShowBusy;
procedure ShowReady;
procedure AddSelectFiles;
procedure DoAddFiles(FileList: TStrings; const folder: string);
procedure ExtractFiles;
procedure DeleteFiles;
end;
{TMyCentralFileHeader = class(TCentralFileHeader)
private
function GetShellSmallIconIndex: integer;
function GetShellTypeName: string;
protected
FShellSmallIconIndex: integer;
FShellTypeName: string;
procedure FillShellInfo;
public
property ShellSmallIconIndex: integer read GetShellSmallIconIndex;
property ShellTypeName: string read GetShellTypeName;
constructor Create;
end;}
{Compression stats related functions}
function GetCompressionRatio(compressed, uncompressed: integer): integer;
function GetBitsPerByte(compressed, uncompressed: integer): Extended;
function GetBitsPerByteStr(compressed, uncompressed: integer): string;
var
MainForm: TMainForm;
(**) implementation (**)
uses DebugFormUnit, ExtractOptionsDlgUnit, AddOptionsDlgUnit, AboutDlgUnit,
ConfigDlgUnit, FileAttrDlgUnit, ConfigUnit,
CompressionStatsDlgUnit, ProgStatsDlgUnit;
{$R *.DFM}
const
CreateNewMsg = 'Use Open to Open or Create a new archive';
(*******************************************************************************
Misc functions
*******************************************************************************)
{-------------------------------------------------------------------------------
CentreFormToMain
----------------
Places the form in the middle of the main form.
If it becomes out of the screen, then it is shifted in.
-------------------------------------------------------------------------------}
procedure CentreFormToMain(form: TForm);
var
NewTop, NewLeft: integer;
begin
NewTop := MainForm.Top - ((form.Height - MainForm.Height) div 2);
NewLeft := MainForm.Left - ((form.Width - MainForm.Width) div 2);
// check if the form is out of the screen
// Full screen x and y are used because CYSCREEN does not account for the
// task bar.
// the system metrics are always gotten because the user may change resolution
// while using the program.
if (NewLeft + form.Width) > Screen.Width then
NewLeft := GetSystemMetrics(SM_CXFULLSCREEN) - form.Width
else if (NewLeft < 0) then NewLeft := 0;
if (NewTop + form.Height) > Screen.Height then
NewTop := GetSystemMetrics(SM_CYFULLSCREEN) - form.Height
else if (NewTop < 0) then NewTop := 0;
form.Left := NewLeft;
form.Top := NewTop;
end;
{-------------------------------------------------------------------------------
GetCompressionRatio
-------------------
Returns the compression ratio calculate from compressed and uncompresse
Notes: The compression ratio is a percentage describing the ratio the file
has shrunk by i.e. if the compression ratio is 30%, the file is 70% of its
original size.
This form of description is used Winzip, Arj and other major archivers.
-------------------------------------------------------------------------------}
function GetCompressionRatio(compressed, uncompressed: integer): integer;
begin
if Uncompressed > 0 then
result := 100 - (INT64(compressed) * 100 div INT64(uncompressed))
else
result := 0;
{try
except
on EDivByZero do
result := 0;
end;}
end;
{-------------------------------------------------------------------------------
GetBitsPerByte
--------------
Gives an approximation of the bits per byte for a file.
The number of bits is rounded to next 8 bits because the exact value is
not known. It is calculated by multiplying compressed by 8.
-------------------------------------------------------------------------------}
function GetBitsPerByte(compressed, uncompressed: integer): extended;
begin
try
if Uncompressed > 0 then
result := compressed / uncompressed * 8
else
result := 0;
except
on EInvalidOp do // Div by zero
result := 0;
end;
end;
function GetBitsPerByteStr(compressed, uncompressed: integer): string;
var
bpb: extended; // bits per byte
s: string; // result string
begin
bpb := GetBitsPerByte(compressed, uncompressed);
Str(bpb:5:3, s);
result := s;
end;
(*******************************************************************************
Column Sort support
*******************************************************************************)
{-------------------------------------------------------------------------------
InverseCompare
--------------
Compares Item1 and Item2, and returns the inverse of the result.
Uses the actual comparison function pointed to by InverseCompareActual to
do the actual comparison. Then internally reverses the result.
-------------------------------------------------------------------------------}
var
InverseCompareActual: TListSortCompare;
function InverseCompare(Item1, Item2: Pointer): Integer;
var
d: integer;
begin
d := InverseCompareActual(Item1, Item2);
if (d > 0) then d := -1
else if (d < 0) then d := 1;
result := d;
end;
{-------------------------------------------------------------------------------
CompareInt
----------
Compares two integers a and b.
Returns:
1 : a > b
-1 : a < b
0 : a = b
-------------------------------------------------------------------------------}
function CompareInt(a, b: integer): integer;
begin
if a > b then
result := 1
else if a < b then
result := -1
else
result := 0;
end;
{-------------------------------------------------------------------------------
Various comparison functions
Notes:
The variuos compare function compares a field in Item1 and Item2. Depending
on the data type of the fields, a different comparison method is used.
CompareStr: to compare strings
CompareInt: to compare integers
-------------------------------------------------------------------------------}
function NameCompare(Item1, Item2: Pointer): Integer;
begin
result := CompareStr(TCentralFileHeader(Item1).filename, TCentralFileHeader(Item2).filename);
end;
function SizeCompare(Item1, Item2: Pointer): Integer;
begin
result := CompareInt(TCentralFileHeader(Item1).uncompressed_size, TCentralFileHeader(Item2).uncompressed_size);
end;
function PackedCompare(Item1, Item2: Pointer): Integer;
begin
result := CompareInt(TCentralFileHeader(Item1).compressed_size, TCentralFileHeader(Item2).compressed_size);
end;
function RatioCompare(Item1, Item2: Pointer): Integer;
var
r1, r2: integer;
begin
r1 := GetCompressionRatio(TCentralFileHeader(Item1).compressed_size, TCentralFileHeader(Item1).uncompressed_size);
r2 := GetCompressionRatio(TCentralFileHeader(Item2).compressed_size, TCentralFileHeader(Item2).uncompressed_size);
result := CompareInt(r1, r2);
end;
function TimeCompare(Item1, Item2: Pointer): Integer;
begin
result := CompareInt(TCentralFileHeader(Item1).Time, TCentralFileHeader(Item2).Time);
end;
function TypeNameCompare(Item1, Item2: Pointer): Integer;
begin
{use TMyCentralFileHeader, derived from TCentralFileHeader.
it adds on ShellTypeName}
result := CompareStr(TCentralFileHeader(Item1).ShellTypeName, TCentralFileHeader(Item2).ShellTypeName);
end;
(*******************************************************************************
Column Data Extractor types
Desc:
Each column in the FileList is represented by a class derived from TColDataExtr.
This makes each column capable of extracting its own data, info (header width,
header), and sort itself (ListSortCompare).
Each child of TColDataExtr
- assigns its own header, width and ListSortCompare in the Create procedure.
- overrides the Extract procedure to return the data it exposes in a string
To add a new column:
Derive a new column from TColDataExtr
Override Create:
- call the inherited create to give a header title and a width
- assign a pointer to the compare procedure if any
Override Extract to return a string for the data
*******************************************************************************)
type
TColDataExtr = class
protected
fheader: string;
fwidth: integer;
FListSortCompare: TListSortCompare;
public
property header: string read fheader;
property width: integer read fwidth;
property ListSortCompare: TListSortCompare read FListSortCompare;
constructor Create(aheader: string; awidth: integer);
function Extract(CFH: TCentralFileHeader): string; virtual; abstract;
end;
TNameColDataExtr = class(TColDataExtr)
public
constructor Create;
function Extract(CFH: TCentralFileHeader): string; override;
end;
TSizeColDataExtr = class(TColDataExtr)
public
constructor Create;
function Extract(CFH: TCentralFileHeader): string; override;
end;
TPackedColDataExtr = class(TColDataExtr)
public
constructor Create;
function Extract(CFH: TCentralFileHeader): string; override;
end;
TTimeColDataExtr = class(TColDataExtr)
public
constructor Create;
function Extract(CFH: TCentralFileHeader): string; override;
end;
TRatioColDataExtr = class(TColDataExtr)
public
constructor Create;
function Extract(CFH: TCentralFileHeader): string; override;
end;
TTypeNameColDataExtr = class(TColDataExtr)
public
constructor Create;
function Extract(CFH: TCentralFileHeader): string; override;
end;
TNumBlocksColDataExtr = class(TColDataExtr)
public
constructor Create;
function Extract(CFH: TCentralFileHeader): string; override;
end;
TDataOffsetColDataExtr = class(TColDataExtr)
public
constructor Create;
function Extract(CFH: TCentralFileHeader): string; override;
end;
{-------------------------------------------------------------------------------
Column Data Extractors
-------------------------------------------------------------------------------}
constructor TColDataExtr.Create;
begin
inherited Create;
fheader := aheader;
fwidth := awidth;
FListSortCompare := nil;
end;
constructor TNameColDataExtr.Create;
begin
inherited Create('Name', 140);
FListSortCompare := NameCompare;
end;
function TNameColDataExtr.Extract(CFH: TCentralFileHeader): string;
begin
result := CFH.filename;
end;
constructor TSizeColDataExtr.Create;
begin
inherited Create('Size', 100);
FListSortCompare := SizeCompare;
end;
function TSizeColDataExtr.Extract(CFH: TCentralFileHeader): string;
begin
result := IntToStr(CFH.uncompressed_size);
end;
constructor TPackedColDataExtr.Create;
begin
inherited Create('Packed', 100);
FListSortCompare := PackedCompare;
end;
function TPackedColDataExtr.Extract(CFH: TCentralFileHeader): string;
begin
result := IntToStr(CFH.compressed_size);
end;
constructor TTimeColDataExtr.Create;
begin
inherited Create('Time', 120);
FListSortCompare := TimeCompare;
end;
function TTimeColDataExtr.Extract(CFH: TCentralFileHeader): string;
begin
result := CFH.TimeStr; // info cached
end;
constructor TRatioColDataExtr.Create;
begin
inherited Create('Ratio', 50);
FListSortCompare := RatioCompare;
end;
constructor TTypeNameColDataExtr.Create;
begin
inherited Create('Type', 130);
FListSortCompare := TypeNameCompare;
end;
function TTypeNameColDataExtr.Extract(CFH: TCentralFileHeader): string;
begin
result := CFH.ShellTypeName;
end;
function TRatioColDataExtr.Extract(CFH: TCentralFileHeader): string;
begin
result := IntToStr(GetCompressionRatio(CFH.compressed_size, CFH.uncompressed_size)) + '%';
end;
constructor TNumBlocksColDataExtr.Create;
begin
inherited Create('Blocks', 50);
end;
function TNumBlocksColDataExtr.Extract(CFH: TCentralFileHeader): string;
begin
result := IntToStr(CFH.num_blocks);
end;
constructor TDataOffsetColDataExtr.Create;
begin
inherited Create('Data', 50);
end;
function TDataOffsetColDataExtr.Extract(CFH: TCentralFileHeader): string;
begin
result := IntToStr(CFH.data_offset);
end;
(*******************************************************************************
TMainForm
*******************************************************************************)
{-------------------------------------------------------------------------------
Create/Destroy
-------------------------------------------------------------------------------}
procedure TMainForm.FormCreate(Sender: TObject);
var
FileInfo: TSHFileInfo;
ImageListHandle: THandle;
begin
{-- IMPORTANT!!! Set parameters for Resource1.ArchiveMan --}
Resource1.ArchiveMan.TempDir := ConfigMan.temp_dir;
{----------------------------------------------------------}
// accept dragged files
DragAcceptFiles(handle, true);
Caption := Application.Title;
//Application.OnHint := DisplayHint;
ColMan := TObjectList.Create;
ImageListHandle := SHGetFileInfo('C:\',
0,
FileInfo,
SizeOf(FileInfo),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
// we only get the handle, so we must assign it manually
SendMessage(FileList.Handle, LVM_SETIMAGELIST, LVSIL_SMALL, longint(ImageListHandle));
{ImageListHandle := SHGetFileInfo('C:\',
0,
FileInfo,
SizeOf(FileInfo),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
SendMessage(FileList.Handle, LVM_SETIMAGELIST, LVSIL_SMALL, ImageListHandle);}
{List view}
ColMan.Add(TNameColDataExtr.Create);
ColMan.Add(TSizeColDataExtr.Create);
ColMan.Add(TTypeNameColDataExtr.Create);
ColMan.Add(TRatioColDataExtr.Create);
ColMan.Add(TPackedColDataExtr.Create);
ColMan.Add(TTimeColDataExtr.Create);
ColMan.Add(TNumBlocksColDataExtr.Create);
{$IFDEF DEBUG}
// debug columns
ColMan.Add(TDataOffsetColDataExtr.Create);
{$ENDIF}
GenerateColumns;
// disable archive action buttons in case nothing is opened
EnableArchiveActions(false);
EnableFileListSensitiveItems(false);
{$IFDEF DEBUG}
// open an archive by default in debug mode
// not necessary because can open from param line
{OpenArchive('c:\ctest\a.rs', true);}
{$ENDIF}
// if the user passed an archive name in the command line, open it.
if (ParamCount > 0) then
OpenArchive(ParamStr(1), true);
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
DragAcceptFiles(handle, false);
ColMan.Free;
end;
{-------------------------------------------------------------------------------
DisplayHint
-----------
Displays the hint in the status bar.
This is an event handler.
-------------------------------------------------------------------------------}
{procedure TMainForm.DisplayHint(Sender: TObject);
begin
ShowStatusMessage(Application.Hint);
end;}
{-------------------------------------------------------------------------------
GenerateColumns
---------------
Takes the columns in ColMan and shows it in the FileList
Desc:
Creates the various columns (header + width) in the FileList
-------------------------------------------------------------------------------}
procedure TMainForm.GenerateColumns;
var
i: integer;
ColDataExtr: TColDataExtr;
begin
FileList.Columns.Clear;
for i := 0 to ColMan.Count-1 do
begin
ColDataExtr := ColMan[i] as TColDataExtr;
with FileList.Columns.Add do begin
Caption := ColDataExtr.header;
Width := ColDataExtr.Width;
end;
end;
end;
{-------------------------------------------------------------------------------
Application Status
------------------
ShowBusy: Shows a 'busy' cursor
ShowReady: Shows a default cursor, usually an arrow.
-------------------------------------------------------------------------------}
procedure TMainForm.ShowBusy;
begin
Screen.Cursor := crHourGlass;
// allow time to redraw the cursor
Application.ProcessMessages;
end;
procedure TMainForm.ShowReady;
begin
Screen.Cursor := crDefault;
// allow time to redraw the cursor
Application.ProcessMessages;
end;
(*******************************************************************************
Button Handler
--------------
Event handlers that handle a button or menu click
*******************************************************************************)
{CompressBtn and DecompressBtn are used during debugging to simplify adding files.
The buttons are not visible in the release version}
procedure TMainForm.CompressBtnClick(Sender: TObject);
var
FileList: TStringList;
begin
Screen.Cursor := crHourGlass;
FileList := TStringList.Create;
FileList.Add('c:\windows\network.txt');
Resource1.ArchiveMan.AddFiles(FileList, 'c:\ctest\');
FileList.Free;
Screen.Cursor := crDefault;
end;
procedure TMainForm.DecompressBtnClick(Sender: TObject);
begin
{Screen.Cursor := crHourGlass;
ArchiveManager.dest_dir := 'c:\ctestout\';
ArchiveManager.ExtractFile(0);
Screen.Cursor := crDefault;}
end;
procedure TMainForm.ExitBtnClick(Sender: TObject);
begin
end;
{-------------------------------------------------------------------------------
Menu Item Handler
-------------------------------------------------------------------------------}
procedure TMainForm.MICompressionStatsClick(Sender: TObject);
begin
CompressionStatsDlg.ShowModal;
end;
procedure TMainForm.MIExitClick(Sender: TObject);
begin
CloseArchive;
Application.Terminate;
end;
procedure TMainForm.MIDeleteClick(Sender: TObject);
begin
DeleteFiles;
end;
procedure TMainForm.MISelectAllClick(Sender: TObject);
var
i: integer;
ListItem: TListItem;
begin
for i := 0 to FileList.Items.Count-1 do
begin
ListItem := FileList.Items[i];
ListItem.Selected := true;
end;
end;
procedure TMainForm.MIDeselectAllClick(Sender: TObject);
var
i: integer;
ListItem: TListItem;
begin
for i := 0 to FileList.Items.Count-1 do
begin
ListItem := FileList.Items[i];
ListItem.Selected := false;
end;
end;
procedure TMainForm.MIConfigurationClick(Sender: TObject);
begin
ConfigDlg.ShowModal;
end;
procedure TMainForm.MIAboutClick(Sender: TObject);
begin
AboutDlg.ShowModal;
end;
procedure TMainForm.MIPropertiesClick(Sender: TObject);
begin
end;
(*******************************************************************************
Message Handling
*******************************************************************************)
procedure TMainForm.WMMove(var m: TMessage);
begin
if ConfigMan.ShowDebugForm and ConfigMan.ClipDebugFormToMainForm then
begin
DebugForm.Left := Left + Width;
DebugForm.Top := Top;
end;
end;
{-------------------------------------------------------------------------------
WMDropFiles
-----------
Handles the dropping of files into resource
Creates the file list and passes it to DoAddFiles.
If only one file is dropped and this file is a resource archive, then
it is opened instead of being added. To add reSource archives, use Add.
If the archive is not opened, the user will be prompted to open an archive.
-------------------------------------------------------------------------------}
procedure TMainForm.WMDropFiles(var msg : TMessage);
const
FNAME_SIZE = 30 * 1024;
var
i, n : integer;
size : integer;
fname : PChar;
hdrop : THandle;
FileList: TStringList;
begin
FileList := TStringList.Create;
// fname must handle long file name and paths
fname := StrAlloc(FNAME_SIZE);
// get the drop handle
hdrop := msg.WParam;
// find out how many files were dropped by passing $ffff in arg #2
n := DragQueryFile(hdrop, $FFFFFFFF, nil, 0);
// loop through, reading in the filenames (w/full paths).
for i := 0 to (n - 1) do
begin
// get the size of the filename string by passing 0 in arg #4
size := DragQueryFile(hdrop, i, nil, 0);
// make sure it won't overflow our string (255 char. limit)
if size < FNAME_SIZE then
begin
// get the dropped filename.
DragQueryFile(hdrop, i, fname, size + 1);
// add the filename to the file list
FileList.Add(string(fname));
end
else
ShowError('File name in drag drop too long.');
end;
// if only one file is dropped and this file is a reSource archive, then
// it is opened instead of being added. To add reSource archives, use Add.
if (FileList.Count = 1) and
(UpperCase(ExtractFileExt(FileList[0])) = '.' + Sresource_EXT) then
OpenArchive(FileList[0], true)
else
// pass a nil in folder because all the folder names are included in FileList
DoAddFiles(FileList, '');
// return zero
msg.Result := 0;
// let the inherited message handler (if there is one) go at it
inherited;
// free memory
StrDispose(fname);
FileList.Free;
end;
(*******************************************************************************
Support/Wrapper functions
*******************************************************************************)
{-------------------------------------------------------------------------------
ShowStatusMessage
-----------------
simple wrapper to write a short message to the status bar
-------------------------------------------------------------------------------}
procedure TMainForm.ShowStatusMessage(const s: string);
begin
AddLog(s, clRed);
StatusBar.SimpleText := s;
end;
{-------------------------------------------------------------------------------
GetNumFilesStr
--------------
returns a string containing x + 'file' + 's'|''
The x could be 'no' or the number of files
an 's' will be appended if the number of files is greater than 1
Notes:
This is for easy reading on the user's part.
-------------------------------------------------------------------------------}
function TMainForm.GetNumFilesStr(const num: integer): string;
var
s: string;
begin
if (num = 0) then
s := 'no'
else
s := IntToStr(num);
s := s + ' file';
if (num <> 1) then
s := s + 's';
result := s;
end;
{-------------------------------------------------------------------------------
ShowProgress
------------
updates the progress bar to reflect the new progress
-------------------------------------------------------------------------------}
procedure TMainForm.ShowProgress(const num: integer);
begin
{FileProgressBar.Progress := num;
Application.ProcessMessages;}
end;
{-------------------------------------------------------------------------------
EnableArchiveActions
--------------------
enables items that can only be performed if an archive is opened
-------------------------------------------------------------------------------}
procedure TMainForm.EnableArchiveActions(const Enable: boolean);
begin
CloseAct.Enabled := Enable;
AddSelectFilesAct.Enabled := Enable;
MICompressionStats.Enabled := Enable;
end;
{-------------------------------------------------------------------------------
EnableFileListSensitiveItems
----------------------------
enable/disable FileList sensitive items
Notes:
These buttons or menu items should only be available if the file list has
entries
-------------------------------------------------------------------------------}
procedure TMainForm.EnableFileListSensitiveItems(const Enable: boolean);
begin
ExtractSelFilesAct.Enabled := Enable;
SelectAllAct.Enabled := Enable;
end;
{-------------------------------------------------------------------------------
OpenArchive
-----------
enables action items, displays file stats in status bar and opens the archive
Notes:
if file is not opened, the process cleans up and returns to the 'nothing is
opened' state.
-------------------------------------------------------------------------------}
procedure TMainForm.OpenArchive(const filename: string; const create_new_prompt: boolean);
begin
// reset variables for new archive
TotalSelFileSize := 0;
// archive manager
// close archive if it is currently open
//if Assigned(Resource1.ArchiveMan) then CloseArchive;
//ArchiveManager := TArchiveManager.Create;
//ArchiveManager.OnCentralDirChange := ArchiveManOnCentralDirChange;
try
Resource1.ArchiveMan.OpenArchive(filename, create_new_prompt);
EnableArchiveActions(true);
Caption := 'resource - ' + Resource1.ArchiveMan.archive_file_full_path;
Application.Title := Caption;
if (Resource1.ArchiveMan.ArchiveFile.CentralDir.Count = 0) then
ShowStatusMessage('Archive is empty. Use ''Add'' to add files to the archive.')
else
ShowStatusMessage('Archive contains ' + GetNumFilesStr(Resource1.ArchiveMan.ArchiveFile.CentralDir.Count));
except
on EArchiveOpenError do
begin
ShowStatusMessage(CreateNewMsg);
end;
on EUserCancel do
begin
ShowStatusMessage(CreateNewMsg);
end;
on ESignatureWrong do
begin
// the message is already inside. use default exception handler to display
// the message
raise ESignatureWrong.Create;
end;
else
ShowStatusMessage(CreateNewMsg);
ShowMessage('File cannot be opened.');
end;
end;
{-------------------------------------------------------------------------------
CloseArchive
------------
disables action items, clears the status bar and closes the archive
-------------------------------------------------------------------------------}
procedure TMainForm.CloseArchive;
begin
// clear the filename in caption
Caption := 'Resource';
Application.Title := Caption;
// clear the archive file list
FileList.Items.BeginUpdate;
FileList.Items.Clear;
FileLIst.Items.EndUpdate;
// disable archive buttons
EnableArchiveActions(false);
EnableFileListSensitiveItems(false);
Resource1.ArchiveMan.CloseArchive;
ShowStatusMessage('');
end;
(*******************************************************************************
Event handlers
*******************************************************************************)
{-------------------------------------------------------------------------------
FormResize
----------
Move the DebugForm around with the main form.
-------------------------------------------------------------------------------}
procedure TMainForm.FormResize(Sender: TObject);
begin
if ConfigMan.ShowDebugForm and ConfigMan.ClipDebugFormToMainForm then
begin
DebugForm.Left := Left + Width;
DebugForm.Top := Top;
end;
end;
{-------------------------------------------------------------------------------
FormClose
---------
Closes the archive and form.
-------------------------------------------------------------------------------}
procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
CloseArchive;
Action := caFree;
end;
{-------------------------------------------------------------------------------
FileListColumnClick
-------------------
Called when a column is clicked
The colum is sorted. If it is already in ascending order, it is sorted in
descending order and vice versa.
-------------------------------------------------------------------------------}
procedure TMainForm.FileListColumnClick(Sender: TObject;
Column: TListColumn);
var
ListSortCompare: TListSortCompare; // comparison function
ColDataExtr: TColDataExtr; // entry in ColMan
sorted_msg: string; // the msg to disp. in the status bar about the sort done.
begin
if not Resource1.ArchiveMan.IsArchiveOpen then exit;
{Check for Archive File Opened!}
// sort the central dir, then update the filelist
// get the sort function from ColMan
ColDataExtr := TColDataExtr(ColMan[Column.Index]);
ListSortCompare := ColDataExtr.ListSortCompare;
if Assigned(ListSortCompare) then
begin
ShowBusy;
sorted_msg := 'List sorted according to ' + ColDataExtr.header;
if IsSortedAscending(Column) then
begin
// sort inversed
InverseCompareActual := ListSortCompare;
ListSortCompare := InverseCompare;
sorted_msg := sorted_msg + ' inversed';
end;
Resource1.ArchiveMan.ArchiveFile.CentralDir.Sort(ListSortCompare);
Resource1CentralDirChange(self);
ShowStatusMessage(sorted_msg);
ShowReady;
end
else
Application.MessageBox('A sort algorithm is not available for this column', 'Sorry', 0);
end;
{-------------------------------------------------------------------------------
FileListPopupPopup
------------------
Called when the context sensitive menu for the FileList is called
Desc:
Enables the properties menu item depending on whether anything is selected.
-------------------------------------------------------------------------------}
procedure TMainForm.FileListPopupPopup(Sender: TObject);
begin
// check if the menu items are applicable in the current context
// if no files are selected, then no file property can be changed
MIProperties.Enabled := Assigned(FileList.Selected);
end;
{-------------------------------------------------------------------------------
FileListChange
--------------
event handler. called when certain properties of the file list changes.
Desc:
We capture the change in selected items to calculate the total size of
the items selected.
-------------------------------------------------------------------------------}
procedure TMainForm.FileListChange(Sender: TObject; Item: TListItem;
Change: TItemChange);
{var
ListItem: TListItem;
CentralFileHeader: TCentralFileHeader;
TotalSelFileSize: integer;}
begin
(* if (Change = ctState) {and (FileList.SelCount <> ns)} then
begin
// total up the file size for the items selected
TotalSelFileSize := 0;
ListItem := FileList.Selected;
while (ListItem <> nil) do
begin
CentralFileHeader := TCentralFileHeader(ArchiveManager.ArchiveFile.CentralDir[ListItem.Index]);
inc(TotalSelFileSize, CentralFileHeader.uncompressed_size);
ListItem := FileList.GetNextItem(ListItem, sdAll, [isSelected]);
end;
ToggleOnSelEnableBtns;
ShowStatusMessage(GetNumFilesStr(FileList.SelCount) + ' selected. (' + IntToStr(TotalSelFileSize) + ' bytes)');
end; *)
end;
{-------------------------------------------------------------------------------
FileListDblClick
----------------
extracts the selected file
Desc:
When the user double clicks on the file, it is selected and this event
is called.
-------------------------------------------------------------------------------}
procedure TMainForm.FileListDblClick(Sender: TObject);
begin
// extract selected file
// same as selecting the file then pressing extract
if Assigned(FileList.Selected) then
begin
ExtractSelFilesActExecute(Self);
end;
end;
(*******************************************************************************
Common procedures of Buttons and Menus
--------------------------------------
The buttons and menus may have similar entries like 'add', 'delete' and 'extract'.
They will therefore perform the same function so a common procedure for the
action is used.
*******************************************************************************)
{-------------------------------------------------------------------------------
AddSelFiles
-----------
Shows the AddOptionsDlg to allow user to select files to add. If OK, then
adds the selected files to the archive.
Desc:
Shows the progress bar, calculates stats.
-------------------------------------------------------------------------------}
procedure TMainForm.AddSelectFiles;
var
i: integer; // counter
SelFiles: TStringList; // list of files to add
folder: string; // folder of the files to add
begin
// show the AddOptionsDlg to select files to add then add it
AddOptionsDlg.archive_file_folder := Resource1.ArchiveMan.archive_file_folder;
AddOptionsDlg.archive_file_name := Resource1.ArchiveMan.archive_file_name;
if (AddOptionsDlg.ShowModal = mrOK) then
begin
// this code is for TFileListBox (win 3.1)
// create the list of selected files by scanning through the items in
// FileListBox. If the item is selected, then add it to SelFiles.
ShowBusy;
SelFiles := TStringList.Create;
try
with AddOptionsDlg.FileListBox do
begin
// folder of files to add
folder := AddOptionsDlg.FileListBox.Directory;
EDos.AddSlash(folder);
// build list of selected files
for i := 0 to Items.Count-1 do
if Selected[i] then
SelFiles.Add(Items[i]);
end;
DoAddFiles(SelFiles, folder);
finally
// free up any allocated memory
SelFiles.Free;
ShowReady;
end;
end;
end;
{-------------------------------------------------------------------------------
DoAddFiles
----------
Wrapper for ArchiveManager AddFiles. Used by Drag drop handler and AddSelFiles.
Handles the showing and hiding of the file progress bar.
Checks if an archive is open and opens one. User may drag drop without
checking that an archive is open.
-------------------------------------------------------------------------------}
procedure TMainForm.DoAddFiles(FileList: TStrings; const folder: string);
var
files_added: integer;
begin
//PageControl.ActivePageIndex := 1; // focus the log page
AddLog('--ADD FILES', clRed);
// if archive is not opened, open one
{if (ArchiveManager = nil) then
begin
Application.MessageBox('You have not opened an archive. Please open one first.', 'Error', 0);
MIOpenClick(Self); // help user click the open menu item
end;}
// call ArchiveManager to do the actual addition of files
// result it the number of files added
files_added := 0;
//FileProgressBar.Visible := true;
try
files_added := Resource1.ArchiveMan.AddFiles(FileList, folder);
finally
//FileProgressBar.Visible := false;
ShowStatusMessage(GetNumFilesStr(files_added) + ' added');
end;
{end
else
ShowStatusMessage('No archive open.');}
end;
{-------------------------------------------------------------------------------
ExtractFiles
------------
Desc:
Shows the extract dialog and extracts files.
User can select:
- destination dir
- files to extract. all/selected
Shows the progress bar, calculates stats.
-------------------------------------------------------------------------------}
procedure TMainForm.ExtractFiles;
var
i, // counter
files_extracted, // number of files extracted
extracted_size: integer; // total size of files extracted
//indexlist: TIndexList;
List: TList; // list of files to extract
begin
//PageControl.ActivePageIndex := 1;
// Show the ExtractOptionsDlg
// set default options:
// - extract selected files if files are selected
// then let user change options.
with ExtractOptionsDlg do
begin
if (FileList.SelCount = 0) then
begin
RBExtractAllFiles.Checked := true;
RBExtractSelectedFiles.Enabled := false;
end
else
begin
RBExtractSelectedFiles.Enabled := true;
RBExtractSelectedFiles.Checked := true;
end;
end;
if (ExtractOptionsDlg.ShowModal = mrOK) then
begin
AddLog('--EXTRACT', clRed);
// make progress bar visible
//FileProgressBar.Visible := true;
with Resource1.ArchiveMan, ExtractOptionsDlg do
begin
// get the destination directory from the extract options dialog
dest_dir := ExtractOptionsDlg.ExtractDir;
// ensure the directory can be used
EDos.AddSlash(dest_dir);
// use_folder_names is not supported because the interface has not been
// implemented
use_folder_names := false;
end;
// build list of files to extract in ExtractList
List := TList.Create;
if (ExtractOptionsDlg.RBExtractAllFiles.Checked) then // extract all files?
begin
// the user wants to extract all files, transfer all file indexes into
// indexlist
{SetLength(indexlist, FileList.Items.Count);
for i := 0 to FileList.Items.Count-1 do
indexlist[i] := i;}
for i := 0 to FileList.Items.Count-1 do
List.Add(Resource1.ArchiveMan.ArchiveFile.CentralDir[i]);
end
else
begin
// user wants to extract selected files
//GetSelFilesIndexes(indexlist);
GetSelFilesList(List);
end;
// call archivemanager to do the extraction
ShowBusy;
files_extracted := 0;
extracted_size := 0;
try
//ArchiveManager.ExtractIndexes(indexlist, files_extracted, extracted_size);
Resource1.ArchiveMan.ExtractList(List, files_extracted, extracted_size);
finally
List.Free;
//indexlist := nil;
// hide progress bar
//FileProgressBar.Visible := false;
// display the done message in status bar
ShowStatusMessage('Extracted ' + GetNumFilesStr(files_extracted) + ' (' + IntToStr(extracted_size) + ' bytes)');
ShowReady;
end;
end; {ExtractOptionsDlg mrOK}
end;
(*
{-------------------------------------------------
ExtractFile
Wrapper function for ArchiveManager.ExtractFile
Does additional stats collection
--------------------------------------------------}
procedure ExtractFile(idx: integer);
var
CentralFileHeader: TCentralFileHeader;
begin
CentralFileHeader := TCentralFileHeader(ArchiveManager.ArchiveFile.CentralDir[idx]);
try
ArchiveManager.ExtractFile(idx);
inc(files_extracted);
inc(total_size, CentralFileHeader.uncompressed_size);
except
on EFileNotExtracted do begin {nothing} end;
end;
end;
begin
// set options for ExtractOptionsDlg
// extract selected files if files are selected
with ExtractOptionsDlg do
begin
if (FileList.SelCount = 0) then
begin
RBExtractAllFiles.Checked := true;
RBExtractSelectedFiles.Enabled := false;
end
else
begin
RBExtractSelectedFiles.Enabled := true;
RBExtractSelectedFiles.Checked := true;
end;
end;
if (ExtractOptionsDlg.ShowModal = mrOK) then
begin
// make progress bar visible
FileProgressBar.Visible := true;
with ArchiveManager, ExtractOptionsDlg do
begin
// get the destination directory from the extract options dialog
dest_dir := ExtractOptionsDlg.ExtractDir;
// ensure the directory can be used
EDos.AddBackSlash(dest_dir);
// use_folder_names is not supported because the interface has not been
// implemented
use_folder_names := false;
end;
files_extracted := 0;
total_size := 0;
ShowBusy;
try
try
if (ExtractOptionsDlg.RBExtractAllFiles.Checked) then
begin
// extract all files
for i := 0 to FileList.Items.Count - 1 do
ExtractFile(i);
end
else
begin
// extract selected files
ListItem := FileList.Selected;
while (ListItem <> nil) do
begin
ExtractFile(ListItem.Index);
ListItem := FileList.GetNextItem(ListItem, sdAll, [isSelected]);
end;
end;
except
on EUserCancel do begin {nothing} end;
end;
finally
// hide progress bar
FileProgressBar.Visible := false;
// display the done message in status bar
ShowStatusMessage('Extracted ' + GetNumFilesStr(files_extracted) + ' (' + IntToStr(total_size) + ' bytes)');
ShowReady;
end;
end; {ExtractOptionsDlg mrOK}
end;
*)
{-------------------------------------------------------------------------------
DeleteFiles
-----------
Deletes selected files from the archive
Desc:
Flags selected items to be deleted then calls ArchiveManager to actually
delete them.
Algo:
set deleted flag for selected files
call ArchiveManager.DeleteFiles
-------------------------------------------------------------------------------}
procedure TMainForm.DeleteFiles;
var
ListItem: TListItem;
CentralFileHeader: TCentralFileHeader;
files_deleted: integer; // num of files deleted
r: integer;
begin
//PageControl.ActivePageIndex := 1;
AddLog('--DELETE', clRed);
ShowBusy;
files_deleted := 0;
try
ListItem := FileList.Selected;
while (ListItem <> nil) do
begin
CentralFileHeader := TCentralFileHeader(Resource1.ArchiveMan.ArchiveFile.CentralDir[ListItem.Index]);
// ask for confirmation to delete the file
if (ConfigMan.confirm_on_delete) then
begin
r := Application.MessageBox(PChar('Are you sure you want to delete the file ''' + CentralFileHeader.filename + ''' ?'),
'Confirm', MB_YESNOCANCEL);
case (r) of
IDYES:
begin
{delete the file once we exit the if}
end;
IDNO:
begin
ListItem := FileList.GetNextItem(ListItem, sdAll, [isSelected]);
Continue;
end;
IDCANCEL:
begin
// do not delete anything
files_deleted := 0;
break;
end;
end;
end; // if confirm_on_delete
CentralFileHeader.Deleted := true;
inc(files_deleted);
ListItem := FileList.GetNextItem(ListItem, sdAll, [isSelected]);
end; // while
FileList.Selected := nil;
if (files_deleted > 0) then
Resource1.ArchiveMan.DeleteFiles;
finally
ShowStatusMessage('Deleted ' + GetNumFilesStr(files_deleted));
ShowReady;
end;
end;
{-------------------------------------------------------------------------------
IsSortedAscending
-----------------
Returns true if Column is sorted in ascending order
Desc:
Runs through the items in FileList and determines if they are in ascending
order.
-------------------------------------------------------------------------------}
function TMainForm.IsSortedAscending(Column: TListColumn): boolean;
var
i, // counter
d: integer; // difference
ListSortCompare: TListSortCompare; // the comparison function for the column
begin
ListSortCompare := TColDataExtr(ColMan[Column.Index]).ListSortCompare;
if (FileList.Items.Count > 1) then
begin
for i := 1 to FileList.Items.Count-1 do
begin
with Resource1.ArchiveMan.ArchiveFile.CentralDir do
d := ListSortCompare(Items[i-1], Items[i]);
if (d > 0) then
begin
result := false;
exit;
end;
end;
end;
result := true;
end;
procedure TMainForm.GetSelFilesList(List: TList);
var
ListItem: TListItem;
begin
ListItem := FileList.Selected;
while (ListItem <> nil) do
begin
List.Add(Resource1.ArchiveMan.ArchiveFile.CentralDir[ListItem.Index]);
ListItem := FileList.GetNextItem(ListItem, sdAll, [isSelected]);
end;
end;
procedure TMainForm.miProgStatsClick(Sender: TObject);
begin
ProgStatsDlg.ShowModal;
end;
procedure TMainForm.Chart1Click(Sender: TObject);
begin
//MTFChartForm.ShowModal;
end;
procedure TMainForm.FileListSelectItem(Sender: TObject; Item: TListItem;
Selected: Boolean);
{var
CentralFileHeader: TCentralFileHeader;}
begin
{CentralFileHeader := TCentralFileHeader(ArchiveManager.ArchiveFile.CentralDir[Item.Index]);
if Selected then
inc(TotalSelFileSize, CentralFileHeader.uncompressed_size)
else
dec(TotalSelFileSize, CentralFileHeader.uncompressed_size);
ToggleOnSelEnableBtns;
ShowStatusMessage(GetNumFilesStr(FileList.SelCount) + ' selected. (' + IntToStr(TotalSelFileSize) + ' bytes)');}
end;
(*procedure TMainForm.DropSourceDrop(Sender: TObject; DragType: TDragType;
var ContinueDrop: Boolean);
var
//indexlist: TIndexList;
files_extracted, extract_size: integer;
temp_dir: string;
i: integer;
CFH: TCentralFileHeader;
List: TList;
begin
// Notes:
// ReleaseCapture must be called to allow user to respond with the mouse
// Extract the selected files to a temporary directory
//Releases mouse from drag op to enable user to respond to Messagebox
ReleaseCapture;
ContinueDrop := true;
List := TList.Create;
try
// extract selected files to a temp dir
GetSelFilesList(List);
try
ArchiveManager.ExtractListToTemp(List, files_extracted, extract_size, temp_dir);
// add the files to move
DropSource.Files.Clear;
//DropSource.Files.Add('c:\temp\ofile.dcu'); // move dummy file
DropSource.Files.Add(temp_dir + '*.*'); // move all files
{for i := 0 to List.Count-1 do
begin
CFH := TCentralFileHeader(List[i]);
DropSource.Files.Add(temp_dir + CFH.filename);
end;}
except
on exception do
begin
// exceptions may interfere with the drag/drop operation so we capture
// here and just abandon the drag drop
ContinueDrop := false;
end;
end;
finally
List.Free;
end;
{
Application.MessageBox('Are you sure', 'Confirm', 0);}
end;
*)
(*procedure TMainForm.FileListMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
var
drag_result: TDragResult;
s: string;
begin
// left mouse button down and move is a drag
if (Shift = [ssLeft]) then
begin
DropSource := TDropFileSource.Create(Self);
DropSource.Files.Clear;
DropSource.Files.Add('c:\temp\dummy file.dcu'); // actual files added onDrop
DropSource.DragTypes := [dtMove];
DropSource.OnDrop := DropSourceDrop;
drag_result := DropSource.Execute;
// remove the temp directory
// WARNING: DEBUG USING DEST_DIR WHICH MAY NOT BE CORRECT
//Sleep(1000);
{s := ArchiveManager.dest_dir;
EDos.DelSlash(s);
EDos.DelTree(s);}
case drag_result of
drCancel, drDropMove:
begin
{nothing}
end;
else
ShowMessage('Error: Unknown drag result');
end;
DropSource.Free;
end;
end;
*)
(*
procedure TMainForm.CacheFileInfo(const startindex, endindex: integer);
var
CFH: TCentralFileHeader;
i: integer;
FileInfo: TSHFileInfo;
DateTime: TDateTime;
DateTimeStr: string;
begin
{Checks that shell info and other file info is available for the central file headers
from startindex to endindex.
if not, will add them}
for i := startindex to endindex do
begin
CFH := TCentralFileHeader(Resource1.ArchiveMan.ArchiveFile.CentralDir[i]);
with CFH do
begin
if not info_cached then
begin
// shell info
SHGetFileInfo(PChar(CFH.filename),
0,
FileInfo,
SizeOf(FileInfo),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_TYPENAME or SHGFI_USEFILEATTRIBUTES);
shell_small_icon_index := FileInfo.iIcon;
shell_type_name := FileInfo.szTypeName;
// cache other info as string
DateTime := FileDateToDateTime(CFH.time);
DateTimeToString(DateTimeStr, 'd/m/yy h:nn AM/PM', DateTime);
time_string := DateTimeStr;
info_cached := true;
end;
end;
end;
end;
*)
(*
procedure TMainForm.FileListData(Sender: TObject; Item: TListItem);
var
CFH: TCentralFileHeader;
j: integer;
begin
{Update data for current item
Get the data from ArchiveManager.ArchiveFile.CentralDir}
{We must check if the Archive is opened, otherwise the CentralDir cannot
be read}
if not Resource1.ArchiveMan.IsArchiveOpen then exit;
with Resource1.ArchiveMan.ArchiveFile do
begin
Assert(CentralDir <> nil);
if (Item = nil) or (Item.Index >= CentralDir.Count) {or
(Item.Caption <> '')} then exit;
{Get Shell info if not available yet}
//CacheFileInfo(Item.Index, Item.Index);
if (ColMan.Count > 0) then
begin
CFH := TCentralFileHeader(CentralDir[Item.Index]);
// icon and column 0 (caption) have to be assigned manually
// the rest we let ColDataExtr extract and assign
// icon index
Item.ImageIndex := CFH.ShellSmallIconIndex;
// column 0 is caption
Item.Caption := TColDataExtr(ColMan[0]).Extract(CFH);
// the rest of the columns are subitems
for j := 1 to ColMan.Count-1 do
Item.SubItems.Add(TColDataExtr(ColMan[j]).Extract(CFH));
end;
end;
end;
*)
(*
procedure TMainForm.FileListDataHint(Sender: TObject; StartIndex,
EndIndex: Integer);
begin
{This one is for quick updating of items in a range.
Not necessary since OnData is already called for each item}
end;
*)
procedure TMainForm.Test(Sender: TObject);
{var
SHFileOpStruct: TSHFileOpStruct;}
begin
{with SHFileOpStruct do
begin
wnd := Self.Handle;
wFunc := FO_DELETE;
pTo := PChar('');
pFrom := PChar('c:\ctestout\*.*');
fFlags := 0;
hNameMappings := nil;
end;
SHFileOperation(SHFileOpStruct);}
try
//EDos.ForceDirectories('c:\rubbish dir\yea\very long long');
EDos.DelTree('c:\temp\no such dir');
except
{on EInOutError do
begin
ShowMessage('Error. Drive not ready');
end;}
end;
end;
procedure TMainForm.SelectAllActExecute(Sender: TObject);
var
i: integer;
ListItem: TListItem;
begin
FileList.SetFocus;
for i := 0 to FileList.Items.Count-1 do
begin
ListItem := FileList.Items[i];
ListItem.Selected := true;
end;
end;
procedure TMainForm.SpeedButton1Click(Sender: TObject);
begin
end;
{-------------------------------------------------------------------------------
ArchiveManOnCentralDirChange
----------------------------
Event Handler. Called when the central directory changes.
Updates the filelist to reflect the CentralDir.
Desc:
Uses ColMan to extract the data from the various columns
-------------------------------------------------------------------------------}
procedure TMainForm.Resource1CentralDirChange(Sender: TObject);
var
CFH: TCentralFileHeader; // entry in CentralDir
i, j: integer; // counters
ListItem: TListItem; // entry in the filelist
begin
// debug: print out block size
{BlockSizeLabel.Caption := IntToStr(ArchiveManager.CentralDir.block_size);}
// update the file list to reflect the new main dir
// call BeginUpdate to prevent the screen from refreshing while we update
FileList.Items.BeginUpdate;
FileList.Items.Clear;
with Resource1.ArchiveMan.ArchiveFile do
begin
if (ColMan.Count > 0) then
begin
for i := 0 to CentralDir.Count-1 do
begin
CFH := TCentralFileHeader(CentralDir[i]);
ListItem := FileList.Items.Add;
ListItem.ImageIndex := CFH.ShellSmallIconIndex;
// column 0 is caption
ListItem.Caption := TColDataExtr(ColMan[0]).Extract(CFH);
// the rest of the columns are subitems
for j := 1 to ColMan.Count-1 do
ListItem.SubItems.Add(TColDataExtr(ColMan[j]).Extract(CFH));
end;
end;
// enable/disable buttons
EnableFileListSensitiveItems(not (CentralDir.Count = 0));
end;
FileList.Items.EndUpdate;
end;
procedure TMainForm.AddSelectFilesActExecute(Sender: TObject);
begin
AddSelectFiles;
end;
procedure TMainForm.ExtractSelFilesActExecute(Sender: TObject);
begin
ExtractFiles;
end;
procedure TMainForm.DelSelFilesActExecute(Sender: TObject);
begin
DeleteFiles;
end;
procedure TMainForm.SetPropertyActExecute(Sender: TObject);
var
CentralFileHeader: TCentralFileHeader;
begin
//PageControl.ActivePageIndex := 1; // focus the log page
{To modify property, a link to the CentralFileHeader entry is gotten from ArchiveFile.
This entry is modified, then rewritten using ArchiveMan.WriteCentralDir}
CentralFileHeader := TCentralFileHeader(Resource1.ArchiveMan.ArchiveFile.CentralDir[FileList.Selected.Index]);
if (FileAttrDlg.Execute(CentralFileHeader) = mrOK) then
begin
AddLog('--SET PROPERTY', clRed);
ShowBusy;
// store config into Central Dir
FileAttrDlg.GetCentralFileHeader(CentralFileHeader);
// rewrite central dir with the new CentralFileHeader
Resource1.ArchiveMan.WriteCentralDir;
ShowReady;
end;
end;
procedure TMainForm.SetPropertyActUpdate(Sender: TObject);
begin
SetPropertyAct.Enabled := FileList.Selected <> nil;
end;
procedure TMainForm.DelSelFilesActUpdate(Sender: TObject);
begin
DelSelFilesAct.Enabled := FileList.Selected <> nil;
end;
procedure TMainForm.SelectAllActUpdate(Sender: TObject);
begin
SelectAllAct.Enabled := FileList.Items.Count > 0;
end;
procedure TMainForm.OpenActExecute(Sender: TObject);
begin
// open an existing archive
OpenDialog.FileName := '';
if (OpenDialog.Execute) then OpenArchive(OpenDialog.FileName, false);
end;
procedure TMainForm.CreateNewActExecute(Sender: TObject);
begin
// open an existing archive
OpenDialog2.FileName := '';
if (OpenDialog2.Execute) then OpenArchive(OpenDialog2.FileName, false);
end;
procedure TMainForm.CloseActExecute(Sender: TObject);
begin
CloseArchive;
end;
procedure TMainForm.AddLog(s: string; Color: TColor = clWindowText; Style: TFontStyles = []);
begin
{ check log limit }
if (RichEdit.Lines.Count > LogLinesLimit) then
RichEdit.Lines.Delete(0);
RichEdit.SelAttributes.Color := Color;
RichEdit.SelAttributes.Style := Style;
RichEdit.Lines.Add(s);
RichEdit.SelStart := length(RichEdit.Text);
//RichEdit.SelLength := 5;
SendMessage(RichEdit.Handle, SB_BOTTOM, 0, 0);
Application.ProcessMessages;
end;
procedure TMainForm.Resource1AddLog(Sender: TObject; s: String);
begin
AddLog(s);
end;
procedure TMainForm.Button1Click(Sender: TObject);
begin
{Test the Stream Compression}
end;
{ TMyCentralFileHeader }
{
constructor TMyCentralFileHeader.Create;
begin
FShellSmallIconIndex := -1; // only retrieve these data when they are needed
FShellTypeName := '?';
end;
procedure TMyCentralFileHeader.FillShellInfo;
var
FileInfo: TSHFileInfo;
begin
SHGetFileInfo(PChar(filename),
0,
FileInfo,
SizeOf(FileInfo),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_TYPENAME or SHGFI_USEFILEATTRIBUTES);
FShellSmallIconIndex; := FileInfo.iIcon;
FShellTypeName := FileInfo.szTypeName;
end;
function TMyCentralFileHeader.GetShellSmallIconIndex: integer;
begin
if FShellSmallIconIndex = -1 then
FillShellInfo;
result := FShellSmallIconIndex;
end;
function TMyCentralFileHeader.GetShellTypeName: string;
begin
if FShellTypeName = '?' then
FillShellInfo;
result := FShellTypeName;
end;
}
end.
Reference in New Issue View Git Blame Copy Permalink