Perform a file search including subdirectories (Views: 27)
Problem/Question/Abstract: How to perform a file search including subdirectories Answer: 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)); 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(aPath) + 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)); 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; |