下面的内容是创建了一个遍历目录的控件。
AllDirs的单元文件中。这个单元文件中具有内建的堆栈，并有一个叫做TRunDirs的对
象，该对象知道如何遍历子文件夹。需要说明的是，TRunDirs是TComponent的派生对象
。不可见控件经常是直接从TComponent派生出来的。根据定义，不可见控件是不可能从
TCustomControl , TGraphicControl或者TWinControl派生出来的，因为它们都是可见的
控件。
这个单元文件的代码如下所示：
unit AllDirs;
interface
{$H+}
uses
Classes, Controls, SysUtils;
type
DirStr = string;
PathStr = string;
NameStr = string;
ExtStr = string;
TStack = class;
TShortStack = class;
TStackAry = array[1..1000] of PString;
TStacksAry = array[1..1000] of TShortStack;
TStack = class(TObject)
First,
Last: Word;
constructor Create;
procedure InitCount;
function IsEmpty: Boolean;
function Count: Integer;
end;
TBigStack = class(TStack)
Stacks: TStacksAry;
destructor Destroy; override;
procedure Push(P: TShortStack);
function Pop: TShortStack;
function PopValue(var Num: Integer): String;
end;
TShortStack = class(TStack)
StackAry: TStackAry;
destructor Destroy; override;
procedure Push(S: String);
function Pop: String;
function GetMoreDirs(DirAndWildCard: String): Integer;
procedure Show;
end;
TFoundFileEvent = procedure(FileName: string; SR: TSearchRec) of Object;
TFoundDirEvent = procedure(DirName: string) of Object;
TRunDirs = class(TComponent)
private
FOnFoundFile: TFoundFileEvent;
FOnProcessDir: TFoundDirEvent;
FFileMask: String; //was Str12
FCurDir: DirStr;
FBigStack: TBigStack;
FShortStack: TShortStack;
protected
procedure PushStack;
procedure ProcessName(FName: String; SR: TSearchRec); virtual;
procedure ProcessDir(Start: String); virtual;
public
constructor Create(Owner: TComponent); override;
destructor Destroy; override;
function Run(Start: PathStr; StartingDirectory: String): String;
published
property OnFoundFile: TFoundFileEvent
read FOnFoundFile write FOnFoundFile;
property OnProcessDir: TFoundDirEvent
read FOnProcessDir write FOnProcessDir;
property CurDir: DirStr read FCurDir;
end;
implementation
{$IfDef Debug}
var
F: Text;
{$EndIf Debug}
function Shorten(S: string; Cut: Integer): string;
begin
SetLength(S, Length(S) - Cut);
Shorten := S;
end;
///////////////////////////////////////
// TStack
///////////////////////////////////////
constructor TStack.Create;
begin
inherited Create;
InitCount;
end;
procedure TStack.InitCount;
begin
First := 1;
Last := 0;
end;
function TStack.IsEmpty: Boolean;
var
OutCome: Boolean;
begin
OutCome := First > Last;
IsEmpty := OutCome
end;
function TStack.Count: Integer;
begin
Count := Last - First;
end;
{==================================================}
destructor TBigStack.Destroy;
var
i: Integer;
begin
for i := First to Last do
Stacks[i].Destroy;
inherited Destroy;
end;
procedure TBigStack.Push(P: TShortStack);
begin
Inc(Last);
Stacks[Last] := P;
end;
function TBigStack.Pop: TShortStack;
begin
Result := nil;
end;
function TBigStack.PopValue(var Num: Integer): String;
begin
Num := 0;
if IsEmpty then begin
PopValue := '-1';
Num := -1;
Exit;
end;
while Stacks[Last].IsEmpty do begin
Inc(Num);
Stacks[Last].Destroy;
Dec(Last);
if IsEmpty then begin
PopValue := '-1';
Num := -1;
Exit;
end;
end;
if Last = 0 then begin
PopValue := '-1';
Exit;
end;
PopValue := Stacks[Last].Pop;
end;
{==================================================}
destructor TShortStack.Destroy;
var
i: Integer;
begin
if not IsEmpty then
for i := First to Last do
DisposeStr(StackAry[i]);
inherited Destroy;
end;
procedure TShortStack.Show;
var
i: Integer;
begin
for i := First to Last do begin
{$IfDef Debug}
WriteLn(F, StackAry[i]^);
{$EndIf}
WriteLn(StackAry[i]^);
end;
{$IfDef Debug}
WriteLn(F, '===============');
{$EndIf}
end;
procedure TShortStack.Push(S: String);
begin
if (S <> '.') and (S <> '..') then begin
Inc(Last);
StackAry[Last] := NewStr(S);
end;
end;
function TShortStack.Pop: String;
var
S: PString;
Temp: ShortString;
begin
S := StackAry[First];
if S <> nil then begin
Temp := S^;
DisposeStr(StackAry[First]);
Inc(First);
Pop := Temp;
end
else begin
WriteLn('Error TShortStack.Pop');
Halt;
end;
end;
function TShortStack.GetMoreDirs(DirAndWildCard: String): Integer;
var
SR: SysUtils.TSearchRec;
Total: Integer;
begin
Total := 0;
if FindFirst(DirAndWildCard, faDirectory + faReadOnly, SR) = 0 then
repeat
if (SR.Attr and faDirectory = faDirectory) then begin
Push(SR.Name);
Inc(Total);
end;
until FindNext(SR) <> 0;
FindClose(SR);
GetMoreDirs := Total;
end;
{=======================================}
constructor TRunDirs.Create(Owner: TComponent);
begin
inherited Create(Owner);
{$IfDef Debug}
Assign(F, 'DirLists.dat');
ReWrite(F);
{$EndIf}
FShortStack := TShortStack.Create;
FBigStack := TBigStack.Create;
end;
destructor TRunDirs.Destroy;
begin
FShortStack.Free;
FBigStack.Free;
{$IfDef Debug}
Close(F);
{$EndIf}
inherited Destroy;
end;
procedure TRunDirs.PushStack;
begin
FBigStack.Push(FShortStack);
FShortStack := TShortStack.Create;
end;
procedure SplitDirName(Path: PathStr; var Dir: DirStr; var WName: String);
begin
Dir := ExtractFilePath(Path);
WName := ExtractFileName(Path);
end;
function RemoveDir(Start: String; NumDirs: Integer): String;
var
i, j: Integer;
CurDir: DirStr;
FileMask: string;
begin
SplitDirName(Start, CurDir, FileMask);
i := Length(CurDir);
for j := 1 to NumDirs + 1 do begin
if CurDir[i] = '\' then begin
CurDir := Shorten(CurDir, 1);
Dec(i);
end;
while CurDir[i] <> '\' do begin
CurDir := Shorten(CurDir, 1);
Dec(i);
end;
end;
RemoveDir := CurDir;
end;
procedure TRunDirs.ProcessName(FName: String; SR: SysUtils.TSearchRec);
begin
if Assigned(FOnFoundFile) then
FOnFoundFile(FName, SR);
end;
procedure TRunDirs.ProcessDir(Start: String);
var
SR: SysUtils.TSearchRec;
DoClose: Boolean;
begin
DoClose := False;
if Assigned(FOnProcessDir) then FOnProcessDir(FCurDir);
if FindFirst(Start, faArchive, SR) = 0 then begin
DoClose := True;
repeat
ProcessName(UpperCase(FCurDir) + SR.Name, SR);
until FindNext(SR) <> 0;
end;
if DoClose then
FindClose(SR);
end;
function TRunDirs.Run(Start: PathStr; StartingDirectory: string): string;
const
DirMask = '*.*';
var
Finished: Boolean;
NewDir, StartedAt: string;
NumDirs: Integer;
OutCome: Integer;
SaveDir: string;
begin
GetDir(0, SaveDir);
try
ChDir(StartingDirectory);
except
raise Exception.Create('Directory does not exist: ' +
StartingDirectory);
end;
Start := ExpandFileName(Start);
FCurDir := ''; FFileMask := '';
Finished := False;
StartedAt := Start;
SplitDirName(Start, FCurDir, FFileMask);
Start := FCurDir + DirMask;
while not Finished do begin
FCurDir := ExtractFilePath(Start);
ProcessDir(FCurDir + FFileMask);
OutCome := FShortStack.GetMoreDirs(Start);
if OutCome > 2 then begin
PushStack;
Start := FCurDir + FBigStack.PopValue(NumDirs) + '\' + DirMask
end else begin
NewDir := FBigStack.PopValue(NumDirs);
FCurDir := RemoveDir(Start, NumDirs);
Start := FCurDir + NewDir + '\' + DirMask;
if (Start = StartedAt) or (NewDir = '-1') then Finished := True;
end;
end;
ChDir(SaveDir);
end;
end.
下面，让我们研究一下这个单元文件中的几个关键的要点。AllDirs是这个特定操作的大
脑。它知道怎样搜索文件夹，怎样找出每个文件夹中的所有文件，怎样通知用户找到了
新的文件夹和文件。FileIter单元增加了把文件和文件夹列表保存在TStringList对象中
去的功能。当然，也可以使用SaveToFile命令把这些列表写到磁盘上去。
搜索文件夹的任务可以使用一种简单的递归算法来完成。不过，递归这项技术通常很慢
，很耗时，同时还要占用大量堆栈空间。因此，AllDirs建立了自己的堆栈并把它找到的
文件夹推进这些堆栈中。
下面的对象都是在AllDirs单元中建立的：
? TStack对象是一个抽象类，它提供了一些可以处理所有堆栈类的基本功能。永远也不
必用到这种类型的实际对象。
? TShortStack对象可以处理一个长达1000个long strings的数组。它具有存储和删除这
些项目的全部逻辑。它把它们存放在一个数组中，这个数组只占用4000字节的内存。每
个long string占4字节，乘以1000，就是4000字节。对于这类程序来说，这个数量有点
过大了，因为不太可能遇到一个1000重嵌套的文件夹。
? TBigStack对象为TShortStack对象创建栈。一个文件夹所拥有的子文件夹的信息可以
存放在TShortStack对象中。但是如果一个文件夹有多个子文件夹，它的子文件夹又有多
个子文件夹，那么就需要用到TBigStack对象了。
? TRunDirs对象里到处都是一系列FindFirst和FindNext调用。它使用这些Delphi函数在
文件夹中查找文件。然后它就把它找到的文件夹推进TShortStack对象和 TBigStack对象
中去。
用经典的比喻来说，这里实现的FIFO（先入先出）堆栈和LIFO（后入先出）堆栈就像是
厨房柜子里的一叠盘子。可以放下一个盘子，然后再把另一个盘子放到它的上面。当需
要盘子时，就从顶端拿走一个，或者是从底部抽出一个，这就要看究竟使用的是FIFO堆
栈还是LIFO堆栈了。把一个盘子放到堆栈的顶部叫做把对象入栈（pushing），而拿走一
个盘子则叫做将对象出栈（popping）。
下面我们来分析，如何来搜索文件夹并处理堆栈。这里的技术核心是调用FindFirst、F
indNext和FindClose，它们可以搜索文件夹、查找特定的文件。
使用FindFirst、FindNext和FindClose就好像是在DOS提示符下，在某个文件夹中使用D
IR命令一样。FindFirst找到文件夹中的第一个文件，FindNext找到剩下的文件。当结束
这个过程时，则应该调用FindClose。
这些调用运行指定文件夹和文件通配符，就像在DOS提示符下使用下面这种命令一样：
Dir C : \ aut*.bat
很显然，这个命令将显示所有以aut开头，以.bat结尾的文件。在典型的情况下，这个命
令将找到AUTOEXEC . BAT文件，也许还有其他一个或两个别的文件。
调用FindFirst时，要传递三个参数：
function FindFirst(const Path:string;Attr:Word;var F:TSearchRec):integer;
第一个参数包括想要查找的文件的路径和文件通配符。例如，可以在这个参数中传递 '
c : \ delphi32 \ source \ vcl \ * . pas '或' c : \ program files \ borland \
delphi 2.0 '。
第二个参数则列出想看的文件的类型。这些文件类型我们都是比较熟悉的，它们在不同
的开发系统中的定义大同小异。文件属性见表21.1。
表21.1 文件属性
faReadOnly $01 只读文件
faHidden $02 隐藏文件
faSysFile $04 系统文件
faVolumeID $08 卷标ID文件
faDirectory $10 文件夹文件
faArchive $20 文档文件
faAnyFile $3F 任何文件
在多数情况下，应该给这个参数传递faArchive。不过，如果想查看文件夹，则应该使用
faDirectory。传递faDirectory的结果是文件夹也会被包括在普通文件列表中，而不是
仅限于文件才能进入列表。如果愿意，可以使用OR（或方法）将几个不同的faXXX常量连
在一起。
最后一个参数是一个TSearchRec类型的变量，它的声明如下：
TSearchRec = record
Fill: array [1..21] of Byte;
Attr: byte;
Time: Longint;
Size: Longint;
Name: string[12];
end;
TSearchRec中最重要的值是Name域，如果调用成功，该字段将确定找到的文件的名称。
如果FindFirst找到了文件，它就返回零，而如果调用失败，则返回一个非零值。
FindNext与FindFirst很相似，只不过这时只需传递一个TSearchRec类型的变量就可以了
，因为FindNext会采用与FindFirst相同的文件通配符和文件属性。和FindFirst一样，
如果FindNext一切顺利，它会返回零，而如果它找不到文件，则会返回一个非零值。在
顺序完成FindFirst或者FindNext后，应该调用FindClose。
知道了这些知识以后，可以用下面这样简单的方法来调用FindFirstFindNext和FindClo
se：
var
SR: TSearchRec;
begin
if FindFirst(Start, faArchive, SR) = 0 then begin
repeat
//DoSomething(SR.Name);
until FindNext(SR) <> 0;
end;
FindClose(SR);
当TRunDirs准备好处理新文件夹时，它把它的名字传递给叫做ProcessDir的方法：
procedure TRunDirs.ProcessDir(Start: String);
var
SR: SysUtils.TSearchRec;
DoClose: Boolean;
begin
DoClose := False;
if Assigned(FOnProcessDir) then FOnProcessDir(FCurDir);
if FindFirst(Start, faArchive, SR) = 0 then begin
DoClose := True;
repeat
ProcessName(UpperCase(FCurDir) + SR.Name, SR);
until FindNext(SR) <> 0;
end;
if DoClose then
FindClose(SR);
end;
ProcessDir在文件夹中的所有文件之间切换，并把找到的每个文件都传递给ProcessNam
e的方法：
procedure TRunDirs.ProcessName(FName: String; SR: SysUtils.TSearchRec);
begin
if Assigned(FOnFoundFile) then
FOnFoundFile(FName, SR);
end;
ProcessDir和ProcessName方法都是虚方法。因此可以创建一个TrunDirs的派生类，重载
其中的某一个方法，并按照自己喜欢的方式作出相应的响应。
创建一个TrunDirs的派生类是一个非常简单的操作，但通过授权模型对事件处理程序作
出反应会更加简单。换句话说，可以建立一个TrunDirs（或者是TJfsFileSearch）的派
生类，然后重载ProcessName方法。这样做可以很容易地访问到被处理的每个名字。但是
，还可以通过一个更简单的方法达到这个目的。具体地说，可以建立一个事件处理程序
，并在每次找到文件时调用这个事件。
要想创建一个像OnXXX这样的事件处理程序，必须首先定义一个指向方法的指针。建立的
这个方法指针将指向在事件发生时应该调用的方法。每一个特定类型的方法处理程序都
会有一个标志。例如，OnClick事件总是得到应该叫做Sender的参数，该参数是TObject
类型的。
参数为Sender/Tobject类型的例程，被叫做TNotifyEvent，是像下面这样声明的：
TNotifyEvent = procedure ( Sender : TObject ) of object ;
这句代码只是一个方法指针的声明。其中令人困惑的是“of object”语句。如果把它去
掉，可以很容易地说出这里正在进行什么。“of object”只不过是要告诉编译器这是一
个指向方法的指针，而不是指向函数或进程的指针。
从TNotifyEvent方法指针声明到一个下面这样的事件很容易理解：
procedure TForm1.Button1Click ( Sender : TObject ) ;
Button1Click方法就是一个TNotifyEvent类型的方法的实例。一个OnClick事件所做的全
部工作就是提供一个与存放在对象中的方法指针相匹配的方法实例。
可以像下面这样为OnFoundDir事件声明方法指针：
TFoundDirEvent = procedure ( DirName : string ) of Object ;
这个指针指向的方法只有一个字符串参数。当点击Events页面的OnFoundDir事件时，就
会创建出这种类型的方法。当单击一个按钮的OnClick事件时也会发生几乎同样的事，只
不过方法类型的句柄不同而已，更具体地说，这时的句柄是定义在AllDirs单元中的，而
不是随Delphi发送的那些单元中。
为了定义我们自己的事件，我们也声明了下面的事件类型：
TFoundFileEvent = procedure ( FileName : string ;
SR : SysUtils . TSearchRec ) of Object ;
OnFoundFile事件是Test1程序中实际用到的一个事件。但是我们只是集中讨论了OnFoun
dDir事件，这是因为OnFoundDir事件只有一个参数，因而比较容易理解。
可以像下面这样声明一个指向这种类型的对象的指针：
FOnProcessDir : TFoundDirEvent ;
现在TRunDirs有了一个内部变量，这个变量可以被设成等于正确类型的方法。不论发生
了哪种特定事件，TRunDirs对象都能使用这个变量调用指定的方法来处理该事件：
if Assigned ( FOnProcessDir ) then FOnProcessDir ( FCurDir ) ;
这句代码来自ProcessDir方法的主体。它首先检查FOnProcessDir是否被设成了nil，如
果不是nil，那意味着已经指定了一个方法来处理这个事件，然后就调用这个方法。
事件句柄只是一种包含有指向函数的指针的属性，而不是其他什么别的类型的数据。下
面是关于OnProcessDir事件的声明：
property OnProcessDir : TFoundDirEvent
read FOnProcessDir
write FOnProcessDir ;
可以看到这个属性被声明为TFoundDirEvent类型，而不是其他别的什么更简单的类型，
例如字符串、整数或者集合。这个属性是作为一个接口，为以前提到过的FOnProcessDi
r变量服务的。TFoundDirEvent隐藏在私有部分，其他对象是看不到的：
private
FonProcessDir : TFoundDirEvent ;
可以看到，FOnProcessDir就是一个方法指针。它就是另一种4字节的指针，只不过它所
指向的变量恰巧是一个方法指针，或者更具体地说，是一个事件句柄。
事件句柄很有吸引力，这是因为它们可以很容易地从属性编辑器那里访问到。双击事件
句柄的属性编辑器，与该事件相关的方法就会立刻被插入到代码中。简而言之，事件句
柄是代码生成器的一种温和形式，它所生成的代码可以为希望定义的任何种类的方法进
行声明。
通过上面的代码我们建立了一些用来提供最基本的搜索文件夹功能的对象和其他必要的
功能。但是，从程序代码中可以看出，我们并没有注册这样的对象，因为这样的对象的
功能实在是太简单了，我们不希望任何用户在自己的应用程序中直接使用这样的对象。
要使用这样的对象的功能的话，我们建议按照我们的做法，派生其他的控件。