有以下文件夹:
用lazarus中的treeview控件显示,默认是这样的:
现在我们需要按从小到大顺序排列。
先建一个 natural 模块:
unit natural;
{$MODE OBJFPC}{$H+}
// Natural Order String Comparison by Martin Pool
(* -*- mode: c; c-file-style: "k&r" -*-
strnatcmp.c -- Perform 'natural order' comparisons of strings in C.
Copyright (C) 2000, 2004 by Martin Pool <mbp sourcefrog net>
This software is provided 'as-is', without any express or implied
warranty. In no event will the authors be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source distribution.
*)
interface
(* CUSTOMIZATION SECTION
*
* You can change this typedef, but must then also change the inline
* functions in strnatcmp.c *)
type
nat_char = char;
pnat_char = ^nat_char;
function strnatcmp(const a: pnat_char; const b: pnat_char): integer;
function strnatcasecmp(const a: pnat_char; const b: pnat_char): integer;
implementation
(*
FreePascal IsDigits and IsSpace
*)
function IsDigit(ch: Char): Boolean;
begin
Result := ch In ['0'..'9'];
end;
function IsSpace(ch: Char): Boolean;
begin
Result := ch in [' ', #9, #10, #11, #12, #13];
end;
(* partial change history:
*
* 2004-10-10 mbp: Lift out character type dependencies into macros.
*
* Eric Sosman pointed out that ctype functions take a parameter whose
* value must be that of an unsigned int, even on platforms that have
* negative chars in their default char type.
*)
(* These are defined as macros to make it easier to adapt this code to
* different characters types or comparison functions. *)
function nat_isdigit(a: nat_char): boolean; inline;
begin
result := IsDigit(char(a));
end;
function nat_isspace(a: nat_char): boolean; inline;
begin
result := IsSpace(char(a));
end;
function nat_toupper(a: nat_char): nat_char; inline;
begin
result := UpCase(char(a));
end;
function compare_right(a: pnat_char; b: pnat_char): integer;
var
bias : integer = 0;
begin
(* The longest run of digits wins. That aside, the greatest
value wins, but we can't know that it will until we've scanned
both numbers to know that they have the same magnitude, so we
remember it in BIAS. *)
while true do
begin
if (not nat_isdigit(a^) and not nat_isdigit(b^))
then exit(bias)
else if (not nat_isdigit(a^))
then exit(-1)
else if (not nat_isdigit(b^))
then exit(1)
else if (a^ < b^) then
begin
if bias <> 0 then bias := -1;
end
else if (a^ > b^) then
begin
if bias <> 0 then bias := 1;
end
else if (a^ = #0) and( b^ = #0)
then exit(bias);
inc(a);
inc(b);
end;
result := 0;
end;
function compare_left(a: pnat_char; b: pnat_char): integer;
begin
(* Compare two left-aligned numbers: the first to have a
different value wins. *)
while true do
begin
if ( not nat_isdigit(a^) and not nat_isdigit(b^) )
then exit(0)
else if (not nat_isdigit(a^))
then exit(-1)
else if (not nat_isdigit(b^))
then exit(1)
else if (a^ < b^)
then exit(-1)
else if (a^ > b^)
then exit(1);
inc(a);
inc(b);
end;
result := 0;
end;
function strnatcmp0(const a: pnat_char; const b: pnat_char; fold_case: integer): integer;
var
ai, bi: integer;
ca, cb: char;
fractional : boolean;
begin
assert( (a <> nil) and (b <> nil));
ai := 0; bi := 0;
while true do
begin
ca := a[ai];
cb := b[bi];
// skip over leading spaces or zeros
while nat_isspace(ca) do
begin
inc(ai);
ca := a[ai];
end;
while nat_isspace(cb) do
begin
inc(bi);
cb := b[bi];
end;
// process run of digits
if (nat_isdigit(ca) and nat_isdigit(cb)) then
begin
fractional := ((ca = '0') or (cb = '0'));
if fractional then
begin
result := compare_left(a+ai, b+bi);
if result <> 0 then exit;
end
else
begin
result := compare_right(a+ai, b+bi);
if result <> 0 then exit;
end;
end;
if (ca=#0) and (cb=#0) then
begin
(* The strings compare the same. Perhaps the caller
will want to call strcmp to break the tie. *)
exit(0);
end;
if fold_case <> 0 then
begin
ca := nat_toupper(ca);
cb := nat_toupper(cb);
end;
if (ca < cb)
then exit(-1)
else if (ca > cb)
then exit(1);
inc(ai);
inc(bi);
end;
end;
function strnatcmp(const a: pnat_char; const b: pnat_char): integer;
begin
result := strnatcmp0(a, b, 0);
end;
(* Compare, recognizing numeric string and ignoring case. *)
function strnatcasecmp(const a: pnat_char; const b: pnat_char): integer;
begin
result := strnatcmp0(a, b, 1);
end;
end.
在主程序中,建立一个过程:
function TForm1.TreeviewAlphaSort(Node1, Node2: TTreeNode): Integer;
var
a, b: pnat_char;
begin
a := pnat_char(Node1.Text);
b := pnat_char(Node2.Text);
Result := strnatcmp(a, b)
end;
调用该过程:
TreeView1.CustomSort(@TreeviewAlphaSort);
运行结果:
完整代码:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ComCtrls, StdCtrls, natural, LazFileUtils;
type
{ TForm1 }
TForm1 = class(TForm)
Memo1: TMemo;
TreeView1: TTreeView;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
function TreeviewAlphaSort(Node1, Node2: TTreeNode): Integer;
public
end;
var
Form1: TForm1;
function IsEmptyDir(sDir: String): Boolean;
function AttachMentsExists(FileName: String): Boolean;
procedure SetIcons(TreeView1: TTreeView; list: TStringList);
procedure EnumText(s: string; aItem: TTreeNode);
procedure DirToTreeView(Tree: TTreeView; Directory: string; Root: TTreeNode;
IncludeFiles: Boolean; FileExt: string);
function ExtractTreeViewFileName(RootPath: string; TreeView: TTreeView;
FileExt: string): string;
function ExtractNodeFullPath(TreeView: TTreeView): string;
implementation
{$R *.frm}
var
list: TStringList;
RootPath: string;// = 'D:\C++Builder学习大全中文版';
//FileName: string;
{ TForm1 }
function ExtractNodeFullPath(TreeView: TTreeView): string;
var
Path: string;
Parent: TTreeNode;
// Node: TTreeNode;
begin
Path := TreeView.Selected.text;
Parent := TreeView.Selected.Parent;
while Parent <> nil do
begin
Path := Parent.text + '\' + Path;
Parent := Parent.Parent;
end;
Result := Path;
end;
function ExtractTreeViewFileName(RootPath: string; TreeView: TTreeView;
FileExt: string): string;
var
FileName: string;
begin
Result := '';
if TreeView.Selected = nil then
Exit;
FileName := RootPath + ExtractNodeFullPath(TreeView) + FileExt; // 当前选中的文件名
if not FileExists(FileName) then
Exit;
Result := FileName;
end;
{
将1个目录里面所有的文件添加到TREEVIEW中
DirToTreeView(TreeView1,'D:\Data\',nil,True,'.cpp');
}
procedure DirToTreeView(Tree: TTreeView; Directory: string; Root: TTreeNode;
IncludeFiles: Boolean; FileExt: string);
var
SearchRec: TSearchRec;
ItemTemp: TTreeNode;
begin
with Tree.Items do
begin
BeginUpdate;
if Directory[Length(Directory)] <> '\' then
Directory := Directory + '\';
if FindFirst(Directory + '*.*', faDirectory, SearchRec) = 0 then
begin
Application.ProcessMessages;
repeat
{ 添加文件夹 }
if (SearchRec.Attr and faDirectory = faDirectory) and
(SearchRec.Name[1] <> '.') then
begin
if (RightStr(SearchRec.Name, 6) = '_files') or // 不添加 _file这个文件夹
(RightStr(SearchRec.Name, 12) = '_Attachments') then
// 不添加 _AttachMents这个文件夹
Continue;
if (SearchRec.Attr and faDirectory > 0) then
Root := AddChild(Root, SearchRec.Name);
ItemTemp := Root.Parent;
DirToTreeView(Tree, Directory + SearchRec.Name, Root,
IncludeFiles, FileExt);
Root := ItemTemp;
end
{ 添加文件 }
else if IncludeFiles then
if SearchRec.Name[1] <> '.' then
if (RightStr(SearchRec.Name, 4) = FileExt) (* or { 只添加 .CPP格式文件 }
(RightStr(SearchRec.Name, 4) <> '') *) then { 什么格式都添加 }
AddChild(Root, SearchRec.Name);
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
end;
EndUpdate;
end;
end;
procedure EnumText(s: string; aItem: TTreeNode);
var
node: TTreeNode;
str: string;
begin
node := aItem;
while node <> nil do
begin
if s = '' then
str := node.text
else
str := s + '\' + node.text;
list.Add('----'+str);
if node.HasChildren then
EnumText(str, node.getFirstChild);
node := node.getNextSibling;
end;
end;
function IsEmptyDir(sDir: String): Boolean;
var
sr: TSearchRec;
begin
Result := true;
if Copy(sDir, Length(sDir) - 1, 1) <> '\' then
sDir := sDir + '\';
if FindFirst(sDir + '*.*', faAnyFile, sr) = 0 then
repeat
if (sr.Name <> '.') and (sr.Name <> '..') then
begin
Result := False;
break;
end;
until FindNext(sr) <> 0;
FindClose(sr);
end;
{
返回 附件文件夹
"D:\C++Builder学习大全中文版\新建文本文档.htm"
D:\C++Builder学习大全中文版\新建文本文档_Attachments
}
function AttachmentsFolder(FileName: String): string;
begin
Result := ExtractFilePath(FileName) + ChangeFileExt(ExtractFileName(FileName),
'') + '_Attachments';
end;
function AttachMentsExists(FileName: String): Boolean;
var
f: string;
begin
f := ExtractFilePath(FileName) + ChangeFileExt(ExtractFileName(FileName), '')
+ '_Attachments';
Result := DirectoryExists(f);
end;
procedure SetIcons(TreeView1: TTreeView; list: TStringList);
var
i: Integer;
begin
with TreeView1 do
begin
for i := 0 to Items.Count - 1 do
begin
if DirectoryExists(list.Strings[i]) then
begin
Items[i].ImageIndex := 0;
Items[i].SelectedIndex := 0;
Items[i].StateIndex := 0;
end;
{
// 以下代码处理文件
if FileExists(list.Strings[i]) then
begin
Items[i].ImageIndex := 1;
Items[i].SelectedIndex := 1;
Items[i].StateIndex := 1;
end;
// 以下代码处理带附件文件
if (AttachMentsExists(list.Strings[i])) then
if not IsEmptyDir( AttachmentsFolder(list.Strings[i]) ) then
begin
// Form1.Memo1.LINES.Add( AttachmentsFolder(list.Strings[i]));
Items[i].ImageIndex := 2;
Items[i].SelectedIndex := 2;
Items[i].StateIndex := 2;
end;
}
end;
end;
end;
function TForm1.TreeviewAlphaSort(Node1, Node2: TTreeNode): Integer;
var
a, b: pnat_char;
begin
//PChar(Node1.Text), PChar(Node2.Text)
a := pnat_char(Node1.Text);
b := pnat_char(Node2.Text);
//a := pnat_char(ExtractFileNameOnly(List[Index1]));
//b := pnat_char(ExtractFileNameOnly(List[Index2]));
Result := strnatcasecmp(a, b)
//if List.CaseSensitive then
// Result := strnatcmp(a, b)
//else
// Result := strnatcasecmp(a, b);
//Result := -AnsiStrIComp(PChar(Node1.Text), PChar(Node2.Text));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
//RootPath:=ExtractFilePath(Application.ExeName) + 'TestData';
RootPath:='D:\';
Memo1.Clear;
TreeView1.Items.Clear;
DirToTreeView(TreeView1, RootPath, nil, true, '*');
list := TStringList.Create;
EnumText(RootPath, TreeView1.Items.GetFirstNode);
Memo1.text := list.text;
// 对list排序
//list.CustomSort(@CompareStr); // 对文件名列表排序
memo1.Append('-----------------');
memo1.Append(list.text );
SetIcons(TreeView1, list);
//TreeView1.CustomSort(@MyTreeViewSort); //CustomSort(@MyTreeViewSort);
TreeView1.CustomSort(@TreeviewAlphaSort);
//list.Free;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
list.Free;
end;
end.