paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-24 03:59:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

lcl/shellctrls: Add a custom compare function for sorting the nodes in the ShellTreeView while collecting the files/dirs.

Browse Source
This commit is contained in:
wp_xyz 2022-11-30 00:20:01 +01:00
parent 24d0ade4bc
commit cbf44a384b
1 changed files with 111 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

143
lcl/shellctrls.pas
View File

@ -41,7 +41,7 @@ type
TObjectTypes = set of TObjectType;
TFileSortType = (fstNone, fstAlphabet, fstFoldersFirst);
TFileSortType = (fstNone, fstAlphabet, fstFoldersFirst, fstCustom);
TMaskCaseSensitivity = (mcsPlatformDefault, mcsCaseInsensitive, mcsCaseSensitive);
@ -56,6 +56,22 @@ type
TCustomShellTreeView = class;
TCustomShellListView = class;
{ TFileItem }
TFileItem = class(TObject)
private
FFileInfo: TSearchRec;
FBasePath: String;
public
//more data to sort by size, date... etc
isFolder: Boolean;
constructor Create(const DirInfo: TSearchRec; ABasePath: String);
property BasePath: String read FBasePath;
property FileInfo: TSearchRec read FFileInfo write FFileInfo;
end;
TFileItemCompareEvent = function(Item1, Item2: TFileItem): integer of object;
{ TCustomShellTreeView }
TAddItemEvent = procedure(Sender: TObject; const ABasePath: String;
@ -71,10 +87,12 @@ type
FInitialRoot: String;
FUseBuiltinIcons: Boolean;
FOnAddItem: TAddItemEvent;
FOnSortCompare: TFileItemCompareEvent;
{ Setters and getters }
function GetPath: string;
procedure SetFileSortType(const AValue: TFileSortType);
procedure SetObjectTypes(AValue: TObjectTypes);
procedure SetOnSortCompare(AValue: TFileItemCompareEvent);
procedure SetPath(AValue: string);
procedure SetRoot(const AValue: string);
procedure SetShellListView(const Value: TCustomShellListView);
@ -116,6 +134,7 @@ type
property Root: string read FRoot write SetRoot;
property Path: string read GetPath write SetPath;
property OnAddItem: TAddItemEvent read FOnAddItem write FOnAddItem;
property OnSortCompare: TFileItemCompareEvent read FOnSortCompare write SetOnSortCompare;
{ Protected properties which users may want to access, see bug 15374 }
property Items;
end;
@ -202,6 +221,7 @@ type
property OnMouseWheelRight;
property OnSelectionChanged;
property OnShowHint;
property OnSortCompare;
property OnUTF8KeyPress;
property Options;
property TreeLineColor;
@ -416,20 +436,12 @@ begin
Result := MaskCaseSensitivityStrings[CS];
end;
{ TFileItem : internal helper class used for temporarily storing info in an internal TStrings component}
type
{ TFileItem }
TFileItem = class(TObject)
private
FFileInfo: TSearchRec;
FBasePath: String;
public
//more data to sort by size, date... etc
isFolder: Boolean;
constructor Create(const DirInfo: TSearchRec; ABasePath: String);
property FileInfo: TSearchRec read FFileInfo write FFileInfo;
end;
operator = (const A, B: TMethod): Boolean;
begin
Result := (A.Code = B.Code) and (A.Data = B.Data);
end;
{ TFileItem : internal helper class used for temporarily storing info in an internal TStrings component}
constructor TFileItem.Create(const DirInfo:TSearchRec; ABasePath: String);
begin
@ -439,6 +451,32 @@ begin
end;
{ TFileItemAVLTree
Specialized TAVLTree descendant for sorting the TFileItems found by the
helper function GetFilesInDir such that a user-friendly compare function
can be applied. }
type
TFileItemAVLTree = class(TAVLTree)
private
FFileItemCompare: TFileItemCompareEvent;
function InternalFileItemCompare(ATree: TAvlTree; Item1, Item2: Pointer): Integer;
public
constructor CreateFileItemCompare(ACompare: TFileItemCompareEvent);
end;
constructor TFileItemAVLTree.CreateFileItemCompare(ACompare: TFileItemCompareEvent);
begin
FFileItemCompare := ACompare;
inherited CreateObjectCompare(@InternalFileItemCompare);
end;
function TFileItemAVLTree.InternalFileItemCompare(ATree: TAvlTree; Item1, Item2: Pointer): Integer;
begin
Result := FFileItemCompare(TFileItem(Item1), TFileItem(Item2));
end;
{ TShellTreeNode }
procedure TShellTreeNode.SetBasePath(ABasePath: String);
@ -613,7 +651,7 @@ begin
BeginUpdate;
Refresh(nil);
try
SetPath(CurrPath);
SetPath(CurrPath);
except
// CurrPath may have been removed in the mean time by another process, just ignore
on E: EInvalidPath do ;//
@ -623,6 +661,42 @@ begin
end;
end;
procedure TCustomShellTreeView.SetOnSortCompare(AValue: TFileItemCompareEvent);
var
RootNode: TTreeNode;
CurrPath: String;
begin
if TMethod(AValue) = TMethod(FOnSortCompare) then
Exit;
FOnSortCompare := AValue;
if (([csLoading,csDesigning] * ComponentState) <> []) or (FFileSortType <> fstCustom) then
Exit;
CurrPath := GetPath;
try
BeginUpdate;
Items.Clear;
if FRoot = '' then
PopulateWithBaseFiles()
else
begin
RootNode := Items.AddChild(nil, FRoot);
RootNode.HasChildren := True;
RootNode.Expand(False);
try
SetPath(CurrPath);
except
// CurrPath may have been removed in the mean time by another process, just ignore
on E: EInvalidPath do ;//
end;
end;
finally
EndUpdate;
end;
end;
function TCustomShellTreeView.CanExpand(Node: TTreeNode): Boolean;
var
OldAutoExpand: Boolean;
@ -718,7 +792,6 @@ begin
if f1.isFolder then Result:=-1
else Result:=1;
end;
end;
{ Helper routine.
@ -731,15 +804,17 @@ end;
}
procedure GetFilesInDir(const ABaseDir: string; AMask: string;
AObjectTypes: TObjectTypes; AResult: TStrings; AFileSortType: TFileSortType;
ACaseSensitivity: TMaskCaseSensitivity = mcsPlatformDefault);
ACaseSensitivity: TMaskCaseSensitivity = mcsPlatformDefault;
ASortCompare: TFileItemCompareEvent = nil);
var
DirInfo: TSearchRec;
FindResult, i: Integer;
IsDirectory, IsValidDirectory, IsHidden, AddFile, UseMaskList, CaseSens: Boolean;
SearchStr, ShortFilename: string;
MaskList: TMaskList = nil;
Files: TList;
Files: TFileItemAVLTree;
FileItem: TFileItem;
avlNode: TAVLTreeNode;
{$if defined(windows) and not defined(wince)}
ErrMode : LongWord;
{$endif}
@ -755,7 +830,7 @@ begin
Delete(AMask, Length(AMask), 1);
if Trim(AMask) = '' then
AMask := AllFilesMask;
//Use a TMaksList if more than 1 mask is specified or if MaskCaseSensitivity differs from the platform default behaviour
//Use a TMaskList if more than 1 mask is specified or if MaskCaseSensitivity differs from the platform default behaviour
UseMaskList := (Pos(';', AMask) > 0) or
{$ifdef NotLiteralFilenames}
(ACaseSensitivity = mcsCaseSensitive)
@ -778,10 +853,16 @@ begin
end;
try
if AFileSortType = fstNone then
Files:=nil
else
Files := TList.Create;
Files := nil;
case AFileSortType of
fstAlphabet:
Files := TFileItemAVLTree.Create(@FilesSortAlphabet);
fstFoldersFirst:
Files := TFileItemAVLTree.Create(@FilesSortFoldersFirst);
fstCustom:
if ASortCompare <> nil then
Files := TFileItemAVLTree.CreateFileItemCompare(ASortCompare);
end;
i := 0;
if UseMaskList then
@ -837,16 +918,14 @@ begin
if Assigned(Files) then
begin
case AFileSortType of
fstAlphabet: Files.Sort(@FilesSortAlphabet);
fstFoldersFirst: Files.Sort(@FilesSortFoldersFirst);
avlNode := Files.FindLowest;
while Assigned(avlNode) do
begin
FileItem := TFileItem(avlNode.Data);
AResult.AddObject(FileItem.FileInfo.Name, FileItem);
avlNode := Files.FindSuccessor(avlNode);
end;
for i:=0 to Files.Count-1 do
begin
FileItem:=TFileItem(Files[i]);
AResult.AddObject(FileItem.FileInfo.Name, FileItem);
end;
//don't free the TFileItems here, they will freed by the calling routine
Files.Free;
end;
@ -949,7 +1028,7 @@ begin
Items.BeginUpdate;
try
Files.OwnsObjects := True;
GetFilesInDir(ANodePath, AllFilesMask, FObjectTypes, Files, FFileSortType);
GetFilesInDir(ANodePath, AllFilesMask, FObjectTypes, Files, FFileSortType, mcsPlatformDefault, FOnSortCompare);
Result := Files.Count > 0;
for i := 0 to Files.Count - 1 do