<div dir=ltr>
Problem/Question/Abstract:
How to perform a file search including subdirectories
Solve 1:
Recursively scanning all drives:
{excerpt from form declaration, form has a listbox1 for the results, a label1 for progress, a button2 to start the scan, an edit1 to get the search mask from, a button3 to stop the scan.}
private
{ Private declarations }
FScanAborted: Boolean;
public
{ Public declarations }
function ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;
function TForm1.ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;
function ScanDirectory(var path: string): Boolean;
var
SRec: TSearchRec;
pathlen: Integer;
res: Integer;
begin
label1.caption := path;
pathlen := Length(path);
{ first pass, files }
res := FindFirst(path + filemask, faAnyfile, SRec);
if res = 0 then
try
while res = 0 do
begin
hitlist.Add(path + SRec.Name);
res := FindNext(SRec);
end;
finally
FindClose(SRec)
end;
Application.ProcessMessages;
Result := not (FScanAborted or Application.Terminated);
if not Result then
Exit;
{second pass, directories}
res := FindFirst(path + ' *.* ', faDirectory, SRec);
if res = 0 then
try
while (res = 0) and Result do
begin
if ((Srec.Attr and faDirectory) = faDirectory) and (Srec.name <> ' . ')
and (Srec.name <> ' .. ') then
begin
path := path + SRec.name + '\';
Result := ScanDirectory(path);
SetLength(path, pathlen);
end;
res := FindNext(SRec);
end;
finally
FindClose(SRec)
end;
end;
begin
FScanAborted := False;
Screen.Cursor := crHourglass;
try
Result := ScanDirectory(root);
finally
Screen.Cursor := crDefault
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
ch: Char;
root: string;
begin
root := 'C:\';
for ch := 'A' to 'Z' do
begin
root[1] := ch;
case GetDriveType(Pchar(root)) of
DRIVE_FIXED, DRIVE_REMOTE:
if not ScanDrive(root, edit1.text, listbox1.items) then
Break;
end;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin {aborts scan}
fScanAborted := True;
end;
Solve 2:
procedure TFrmRecurseDirTree.RecurseDirTree(APath: string; AList: TStrings);
var
searchRec: TSearchRec;
thePath: string;
begin
if (Length(thePath) > 0) then
Exit;
{Riffle through the subdirectories and find the file(s) there}
thePath := APath;
if (thePath[Length(thePath)] <> '\') then
thePath := thePath + '\';
if FindFirst(thePath + '*.*', faDirectory, searchRec) = 0 then
try
repeat
if (searchRec.Attr and faDirectory > 1) and (searchRec.Name <> '.') and
(searchRec.Name <> '..') then
begin
AList.Add(thePath + searchRec.Name);
RecurseDirTree(thePath + searchRec.Name + '\', AList);
Application.ProcessMessages;
end;
until
FindNext(searchRec) <> 0;
finally
SysUtils.FindClose(searchRec);
end;
end;
Solve 3:
Here is a procedure to scan for all bitmaps below the current directory and add them to a list. It can easily be modified to add all sub-directories to the list, just add "List.Add..." just before "ScanDirectory..." and delete the part that adds the bitmap filenames. Maybe it's better to change faAnyFile to faDirecory, but I am not sure if this will return all directories including hidden ones etc.
procedure TForm1.ScanDirectory(Path: string; List: TStringList; SubDirFlag: Boolean);
var
SearchRec: TSearchRec;
Ext: string;
begin
if Path[Length(Path)] <> '\' then
Path := Path + '\';
if FindFirst(Path + '*.*', faAnyFile, SearchRec) = 0 then
begin
repeat
if SearchRec.Attr = faDirectory then
begin
if SubDirFlag and (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
ScanDirectory(Path + SearchRec.Name, List, SubDirFlag);
end
else
begin
Ext := UpperCase(ExtractFileExt(SearchRec.Name 1;);
if (Ext = '.BMP') then
begin
List.Add(Path + SearchRec.Name);
end;
end;
until
FindNext(SearchRec) <> 0;
end;
end;
Use it as follows:
ScanDirectory(GetCurrentDir, YourStringList, False);
Solve 4:
procedure TForm1.Button1Click(Sender: TObject);
var
SearchRec: TSearchRec;
begin
if FindFirst('c:\images\*.jpg', faAnyFile, SearchRec) = 0 then
try
repeat
listbox1.items.add(searchrec.name);
until
Findnext(SearchRec) <> 0;
finally
FindClose(SearchRec);
end;
end;
Note: if you are displaying many items, you will probably want to wrap the code within listbox1.items.BeginUpdate/EndUpdate.
Solve 5:
Searching for a file in a directory:
function FileExistsExt(const aPath, aFilename: string): Boolean;
var
DSearchRec: TSearchRec;
begin
Result := FileExists(IncludeTrailingPathDelimiter(aP ath) + aFilename);
if not Result then
begin
if FindFirst(APath + '\*', faDirectory, DSearchRec) = 0 then
begin
repeat
if (DSearchRec.Name <> '.') and (DSearchRec.Name <> '..') then
Result := FileExistsExt(IncludeTrailingPathDelimiter( ;aPath) +
DSearchRec.Name, aFilename);
until
FindNext(DSearchRec) <> 0;
end;
FindClose(DSearchRec);
end;
end;
Usage:
{ ... }
if FileExistsExt('C:', 'Testfile.dat') then
{ ... }
Solve 6:
The following function receives as parameters a file specification (like for example 'C:\My Documents\*.xls' or 'C:\*' if you want to search the entire hard disk) and optionally a set of attributes (exactly as Delphi's FindFirst function), and it returs a StringList with the full pathnames of the found files. You should free the StringList after using it.
interface
function FindFile(const filespec: TFileName; attributes: integer
= faReadOnly or faHidden or faSysFile or faArchive): TStringList;
implementation
function FindFile(const filespec: TFileName;
attributes: integer): TStringList;
var
spec: string;
list: TStringList;
procedure RFindFile(const folder: TFileName);
var
SearchRec: TSearchRec;
begin
// Locate all matching files in the current
// folder and add their names to the list
if FindFirst(folder + spec, attributes, SearchRec) = 0 then
begin
try
repeat
if (SearchRec.Attr and faDirectory = 0) or
(SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
list.Add(folder + SearchRec.Name);
until FindNext(SearchRec) <> 0;
except
FindClose(SearchRec);
raise;
end;
FindClose(SearchRec);
end;
// Now search the subfolders
if FindFirst(folder + '*', attributes
or faDirectory, SearchRec) = 0 then
begin
try
repeat
if ((SearchRec.Attr and faDirectory) <> 0) and
(SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
RFindFile(folder + SearchRec.Name + '\');
until FindNext(SearchRec) <> 0;
except
FindClose(SearchRec);
raise;
end;
FindClose(SearchRec);
end;
end; // procedure RFindFile inside of FindFile
begin // function FindFile
list := TStringList.Create;
try
spec := ExtractFileName(filespec);
RFindFile(ExtractFilePath(filespec) 1;;
Result := list;
except
list.Free;
raise;
end;
end;
Sample call
You can try this function placing a ListBox and a button on a form and adding this code to the OnClick event of the button:
procedure TForm1.Button1Click(Sender: TObject);
var
list: TStringList;
begin
list := FindFile('C:\Delphi\*.pas');
ListBox1.Items.Assign(list);
list.Free;
end;
Solve 7:
I thought if there was a way to create a function that does not recursively call itself to list all the files in the harddisk, so that there might be some improvement in speed, other than making the function more complex there were no speed improvements. Here is the code of the function any way.
type
PRecInfo = ^TRecInfo;
Trecinfo = record
prev: PRecInfo;
fpathname: string;
srchrec: Tsearchrec;
end;
function TForm1.RecurseDirectory1(fname: string): tstringlist;
var
f1, f2: Tsearchrec;
p1, tmp: PRecInfo;
fwc: string;
fpath: string;
fbroke1, fbroke2: boolean;
begin
result := tstringlist.create;
fpath := extractfilepath(fname);
fwc := extractfilename(fname);
new(p1);
p1.fpathname := fpath;
p1.prev := nil;
fbroke1 := false;
fbroke2 := false;
while (p1 <> nil) do
begin
if (fbroke1 = false) then
if (fbroke2 = false) then
begin
if (findfirst(fpath + '*', faAnyfile, f1) <> 0) then
break;
end
else if (findnext(f1) <> 0) then
begin
repeat
findclose(f1);
if (p1 = nil) then
break;
fpath := p1.fpathname;
f1 := p1.srchrec;
tmp := p1.prev;
dispose(p1);
p1 := tmp;
until (findnext(f1) = 0);
if (p1 = nil) then
break;
end;
if ((f1.Name <> '.') and (f1.name <> '..') and ((f1.Attr and fadirectory) =
fadirectory)) then
begin
fbroke1 := false;
new(tmp);
with tmp^ do
begin
fpathname := fpath;
srchrec.Time := f1.time;
srchrec.Size := f1.size;
srchrec.Attr := f1.attr;
srchrec.Name := f1.name;
srchrec.ExcludeAttr := f1.excludeattr;
srchrec.FindHandle := f1.findhandle;
srchrec.FindData := f1.FindData;
end;
tmp.prev := p1;
p1 := tmp;
fpath := p1.fpathname + f1.name + '\';
if findfirst(fpath + fwc, faAnyfile, f2) = 0 then
begin
result.add(fpath + f2.Name);
while (findnext(f2) = 0) do
result.add(fpath + f2.Name);
findclose(f2);
end;
fbroke2 := false;
end
else
begin
if (findnext(f1) <> 0) then
begin
findclose(f1);
fpath := p1.fpathname;
f1 := p1.srchrec;
fbroke1 := false;
fbroke2 := true;
tmp := p1.prev;
dispose(p1);
p1 := tmp;
end
else
begin
fbroke1 := true;
fbroke2 := false;
end;
end;
end;
fpath := extractfilepath(fname);
if findfirst(fname, faAnyfile, f1) = 0 then
begin
result.add(fpath + f2.Name);
while (findnext(f1) = 0) do
result.add(fpath + f2.Name);
findclose(f1);
end;
end;
</div>
قوانین ایجاد تاپیک در تالار
پاسخ با نقل قول