paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-12-08 22:07:25 +01:00
Code Issues Packages Projects Releases Wiki Activity

ShellCtrls: Fix not applying FileSortType if Root <> ''. Issue #0018530.

Browse Source 
git-svn-id: trunk@41149 -
This commit is contained in:
bart 2013-05-12 10:55:58 +00:00
parent 544e9831c2
commit 1650d36464
1 changed files with 30 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
lcl/shellctrls.pas
View File

@ -362,10 +362,15 @@ begin
and (AValue <> '')
and not DirectoryExistsUtf8(ExpandFilename(AValue)) then
Raise Exception.CreateFmt(SShellCtrlsInvalidRoot,[ExpandFileName(AValue)]);
FRoot:=AValue;
if (AValue = '') then
FRoot := GetBasePath
else
FRoot:=AValue;
Items.Clear;
if FRoot = '' then
begin
PopulateWithBaseFiles()
end
else
begin
//Add a node for Root and expand it (issue #0024230)
@ -383,14 +388,33 @@ end;
// ToDo: Optimize, now the tree is populated in constructor, SetRoot and SetFileSortType.
// For some reason it does not show in performance really.
procedure TCustomShellTreeView.SetFileSortType(const AValue: TFileSortType);
var
RootNode: TTreeNode;
CurrPath: String;
begin
if FFileSortType=AValue then exit;
FFileSortType:=AValue;
Items.Clear;
if FRoot = '' then
PopulateWithBaseFiles()
else
PopulateTreeNodeWithFiles(nil, FRoot);
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;