【轉】lazarus:對treeview控制元件內容進行自然排序
阿新 • • 發佈:2022-05-07
有以下資料夾:
用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; constb: 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.