lazarus：對treeview控件內容進行自然排序

有以下文件夾：

用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.