关于超想
本站导航
邮件列表
  首页 | 本站产品 | Delphi资料 | 免费资源 | 程序人生 | 软件工程 | 网站设计 | 推荐网站
你所在的位置 -> 主页 -> 超想软件 -> 编程资料 -> delphi -> 开发技巧 -> API相关 ->详细
相关内容  
 
 
在Delphi程序中应用IE浏览器控件
 
【新品推荐】

  详细内容
 

搜索所有的子目录
作者: 评价: 上站日期: 2001-09-04
内容说明:
来源:

Q: I need to process certain files (*.ssd) in a user selected directory and every nested directory thereafter using Delphi. Anyone has any pointers to give me? What calls to use (my main concern is how to recognize a subdirectory while scanning a directory), may be a fragment of code that does something similar? 

A: FindFirst and FindNext are the key functions. Here is an implementation of their use: 

unit Dirlist1; 

interface 

uses 
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, 

Forms, Dialogs, StdCtrls; 

type 
TForm1 = class(TForm) 
ListBox1: TListBox; 
Edit1: TEdit; 
Label1: TLabel; 
Label2: TLabel; 
Edit2: TEdit; 
Button1: TButton; 
Button2: TButton; 
procedure Button2Click(Sender: TObject); 
procedure Button1Click(Sender: TObject); 
private 
Function LogFiles( Const path: String; Const SRec: TSearchRec ): Boolean; 
{ Private-Declaration } 
public 
{ Public-Declaration } 
end; 

var 

Form1: TForm1; 

implementation 

Type 
TLogFunct = Function( Const path: String; Const SRec: TSearchRec ): Boolean 
of Object; 
{$R *.DFM} 

Procedure FindRecursive( Const path: String; Const mask: String; 
LogFunction: TLogFunct ); 
Var 
fullpath: String; 
Function Recurse( Var path: String; Const mask: String ): Boolean; 
Var 
SRec: TSearchRec; 
retval: Integer; 
oldlen: Integer; 
Begin 
Recurse := True; 

oldlen := Length( path ); 
(* phase 1, look for normal files *) 
retval := FindFirst( path+mask, faAnyFile, SRec ); 
While retval = 0 Do Begin 
If (SRec.Attr and (faDirectory or faVolumeID)) = 0 Then 
(* we found a file, not a directory or volume label, 
log it. Bail out if the log function returns false. *) 
If not LogFunction( path, SRec ) Then Begin 
Result := False; 
Break; 
End; 

retval := FindNext( SRec ); 
End; 
FindClose( SRec ); 
If not Result Then Exit; 

(* Phase II, look for subdirectories and recurse thru them *) 
retval := FindFirst( path+'*.*', faDirectory, SRec ); 
While retval = 0 Do Begin 
If (SRec.Attr and faDirectory) < >  0 Then (* we have a directory *) 
If (SRec.Name < >  '.') and (SRec.Name < >  '..') Then Begin 
path := path + SRec.Name + '\'; 
If not Recurse( path, mask ) Then Begin 

Result := False; 
Break; 
End; 
Delete( path, oldlen+1, 255 ); 
End; 
retval := FindNext( SRec ); 
End; 
FindClose( SRec ); 
End; 
Begin 
If path = '' Then 
GetDir(0, fullpath) 
Else 
fullpath := path; 
If fullpath[Length(fullpath)] < >  '\' Then 
fullpath := fullpath + '\'; 
If mask = '' Then 
Recurse( fullpath, '*.*' ) 
Else 
Recurse( fullpath, mask ); 

End; 


Function TForm1.LogFiles( Const path: String; Const SRec: TSearchRec ): Boolean; 
Begin 
Listbox1.Items.Add( path+SRec.Name ); 
Result := True; (* proceeed with recursion *) 
End; 

procedure TForm1.Button2Click(Sender: TObject); 
begin 
Application.Terminate; 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
ListBox1.Clear; 
Listbox1.Perform( WM_SETREDRAW, 0, 0 ); 
FindRecursive( Edit1.Text, Edit2.Text, LogFiles ); 
Listbox1.Perform( WM_SETREDRAW, 1, 0 ); 

Listbox1.Refresh; 
end; 

end. 

---- dirlist1.dfm ----- 

object Form1: TForm1 
Left = 260 
Top = 222 
Width = 642 
Height = 300 
Caption = 'Recursive Directory Scan' 
Font.Color = clWindowText 
Font.Height = -17 
Font.Name = 'System' 
Font.Style = [] 
PixelsPerInch = 120 
Position = poScreenCenter 
TextHeight = 20 
object Label1: TLabel 
Left = 480 
Top = 24 
Width = 116 
Height = 20 
Caption = '&Path to search' 

FocusControl = Edit1 
end 
object Label2: TLabel 
Left = 480 
Top = 96 
Width = 74 
Height = 20 
Caption = '&File Mask' 
FocusControl = Edit2 
end 
object ListBox1: TListBox 
Left = 16 
Top = 24 
Width = 449 
Height = 225 
ItemHeight = 20 
TabOrder = 0 
end 
object Edit1: TEdit 
Left = 480 
Top = 48 
Width = 137 
Height = 29 
TabOrder = 1 
end 
object Edit2: TEdit 
Left = 480 
Top = 120 

Width = 137 
Height = 29 
TabOrder = 2 
end 
object Button1: TButton 
Left = 480 
Top = 168 
Width = 137 
Height = 33 
Caption = '&Search' 
Default = True 
TabOrder = 3 
OnClick = Button1Click 
end 
object Button2: TButton 
Left = 480 
Top = 216 
Width = 137 
Height = 33 
Caption = 'Close' 
TabOrder = 4 
OnClick = Button2Click 
end 
end 


 
你所在的位置 -> 主页 -> 超想软件 -> 编程资料 -> delphi -> 开发技巧 -> API相关 ->详细
  首页 | 本站产品 | Delphi资料 | 免费资源 | 程序人生 | 软件工程 | 网站设计 | 推荐网站
声明:本站内容除注明原创以外均从网上摘抄,如有侵权请指明。
  如果您对我们的网站有什么意见或者建议,请与我们联系
powered by 建站易上手- V2.0