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.