Solved

Getting all matching filenames in a dir and all sub dirs

Posted on 2002-06-04
9
471 Views
Last Modified: 2010-05-18
Hi...

I need to get a list of all the filenames (including the path) that match a wildcard in a directory and all its dub directories.

For example:

Given the wildcard *.mp3, and a base directory, the program should go through that base directory and all its subdirectories to get all the paths and filenames of all the matching files.  I would like this done in a reusable function so that in my code, I can write something like:

GetMatchingFiles('*.mp3', 'C:\MP3', AStringList);

The program would then put all the paths and filenames into the stringlist I passed it.

If someone could do this, it would be a VERY big help!

Thanks! :D

Matt
0
Comment
Question by:mdavis1982
9 Comments
 
LVL 17

Expert Comment

by:inthe
ID: 7054087
hi,
here is a example:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
ComboBox1: TComboBox;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure GatherFiles(Const Lines: TStrings; Const Dir,Match: String);
var
Rec: TSearchRec;
Found: Integer;
Begin
// Add files
Found:= FindFirst(Dir+'\'+Match, faAnyFile, Rec);
While Found = 0 do
begin
Application.ProcessMessages;
If (Rec.Attr AND faDirectory) = 0 Then Lines.Add(Dir+'\'+Rec.Name);
Found := FindNext(Rec);
End;
FindClose(Rec);
// Find directories (Without match)
Found:= FindFirst(Dir+'\*.*', faAnyFile, Rec);
While Found = 0 do
begin
Application.ProcessMessages;
If ((Rec.Attr AND faDirectory)>0) AND
(Rec.Name<>'.') AND
(Rec.Name<>'..') Then GatherFiles(Lines,Dir+'\'+Rec.Name,Match);
Found := FindNext(Rec);
End;
FindClose(Rec);
End;

procedure TForm1.Button1Click(Sender: TObject);
var
sl : tstringlist;
begin
ComboBox1.items.Clear;
sl := tstringlist.create;
GatherFiles(sl,'C:','*.dll');
//add to comboboxbox from stringlist;
combobox1.Items.AddStrings(sl);
//or straight to combobox:
//GatherFiles(ComboBox1.Items,'C:','*.dll');
If ComboBox1.Items.Count>0 Then
ComboBox1.Text:= ComboBox1.Items[0];
ShowMessage('Found '+IntToStr(ComboBox1.Items.Count)+' matching files.');
end;

end.

0
 
LVL 17

Expert Comment

by:inthe
ID: 7054089
add sl.free also i missed that :)
0
 
LVL 1

Expert Comment

by:bes67
ID: 7054202
try this unit

unit FileSearch;

interface

uses SysUtils, Classes;

procedure GetMatchingFiles(StartDirectory: String; FileName: String; SearchResult: TStrings);

implementation

procedure GetMatchingFiles(StartDirectory:String; FileName:String; SearchResult: TStrings);
var FindList: TStringList;

procedure FileSearch(SearchString: String);
var Finished: Boolean;      
    sr: TSearchRec;  
    res: Integer;      
    path, mask, dir, newdir: string;    
begin
  Finished := false;
  dir := SearchString;
  path := ExtractFilePath(SearchString);
  mask := ExtractFileName(SearchString);
  res := FindFirst(SearchString, faAnyFile, sr);
  while res = 0 do
  begin
    if ((FileGetAttr(path + sr.Name) and faDirectory) = 0) then
        Findlist.Add(path + sr.Name);
    res := FindNext(sr);
  end;
  newdir := ExtractFilePath(SearchString) + '*.*';
  res := FindFirst(newdir, faDirectory, sr);
  while res = 0 do
  begin
    if ((sr.Name <> '.') and (sr.Name <> '..'))
    then
    begin
      newdir := ExtractFilePath(dir) + sr.Name + '\' + mask;
      FileSearch(newdir);
    end;
    res := FindNext(sr);
  end;
end;

begin
  FindList := TStringList.Create;
  try
    if StartDirectory <> '\' then
      StartDirectory := StartDirectory + '\';
    FileSearch(StartDirectory+FileName);
    SearchResult.Assign(FindList);
  finally
    FindList.Free;
  end;
end;

end.
0
Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
LVL 12

Expert Comment

by:Lee_Nover
ID: 7054917
:)
I'll also add my code ... it's been used quite a lot so it works for sure

you simply create an instance of TFileList
then call AddFiles of ParseSource
with ParseSource you can use multiple masks like : 'delph?.*;*.dp?;g??d.?xe'
AddFiles only adds only files with one mask


-----------------------



unit FileStuff_NEW;

interface

uses Windows, Classes, SysUtils, FileCtrl, ShellAPI;

type
  PFileEntry = ^TFileEntry;
  TFileEntry = packed record
    Source: string;
    Destination: string;
    Size: Integer;
  end;

  TFileList = class(TList)
  private
  protected
    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
    function GetItem(Index: Integer): TFileEntry;
    procedure SetItem(Index: Integer; Item: TFileEntry);
  public
    constructor Create;
    destructor Destroy;override;

    function Add(FileEntry: TFileEntry): Integer;overload;
    function Add: PFileEntry;overload;
    procedure Delete(Index: Integer);
    property Items[Index: Integer]: TFileEntry read GetItem write SetItem;
  end;


function FajlSajz(const FileName: string): Integer;
procedure AddFiles(FilesList: TFileList; const Src, Dst, Ext: string);
function ParseSource(const Source, Dest: string; FilesList: TFileList): Integer;
function GetSysIconIndex(const FileName: string; Small: Boolean = true): Integer;


implementation

{ TFileList }

constructor TFileList.Create;
begin
     inherited;
end;

destructor TFileList.Destroy;
begin
     inherited;
end;

function TFileList.Add(FileEntry: TFileEntry): Integer;
var lpFE: PFileEntry;
begin
     New(lpFE);
     lpFE^:=FileEntry;
     Result := inherited Add(lpFE);
end;

function TFileList.Add: PFileEntry;
begin
     New(Result);
     inherited Add(Result);
end;

procedure TFileList.Delete(Index: Integer);
begin
     inherited Delete(Index);
end;

procedure TFileList.Notify(Ptr: Pointer; Action: TListNotification);
begin
     if Action = lnDeleted then begin
        PFileEntry(Ptr)^.Source:='';     // clear the string references if any
        PFileEntry(Ptr)^.Destination:='';// just in case
        Dispose(Ptr);
     end;
     inherited Notify(Ptr, Action);
end;

function TFileList.GetItem(Index: Integer): TFileEntry;
begin
     Result:=PFileEntry(inherited Items[Index])^;
end;

procedure TFileList.SetItem(Index: Integer; Item: TFileEntry);
begin
     PFileEntry(inherited Items[Index])^:=Item;
end;


{ other functions }

function FajlSajz(const FileName: string): Integer;
var SR: TSearchRec;
begin
     Result:=-1;
     if FindFirst(FileName, faAnyfile xor faDirectory, SR) = 0 then begin
        Result:=SR.Size;
        FindClose(SR);
     end;
end;

procedure AddFiles(FilesList: TFileList; const Src, Dst, Ext: string);
var SR: TSearchRec;
    SrcPath: string;
begin
     SrcPath:=ExtractFilePath(Src);
     if FindFirst(Src, faAnyFile xor faDirectory, SR) = 0 then begin
        with FilesList.Add^ do begin
          Size:=SR.Size;
          Source:=SrcPath + SR.Name;
          if Ext = '' then
             Destination:=Dst + SR.Name
          else
             Destination:=Dst + ChangeFileExt(SR.Name, Ext);
        end;

        while FindNext(SR) = 0 do begin
           with FilesList.Add^ do begin
             Size:=SR.Size;
             Source:=SrcPath + SR.Name;
             if Ext = '' then
                Destination:=Dst + SR.Name
             else
                Destination:=Dst + ChangeFileExt(SR.Name, Ext);
             
           end;
        end;
        SysUtils.FindClose(SR);
     end;
end;

function ParseSource(const Source, Dest: string; FilesList: TFileList): Integer;
var
    Files: TStringList;
    Src, Dst, Ext: string;
    DstIsDir, HasWildCards: boolean;
    I: Integer;
label OneFile;
begin
     Result:=0;
     if (Source = '')or(FilesList = nil) then exit;
     FilesList.Clear;
     Files:=TStringList.Create;
     try
        Src:=Source;
        Dst:=Dest;
        DstIsDir:=DirectoryExists(Dst);
        if DstIsDir then if Dst[Length(Dst)] <> '\' then Dst:=Dst + '\';
        while Src[1] = ';' do Delete(Src, 1, 1);
        while Src[Length(Src)] = ';' do Delete(Src, Length(Src), 1);
        Files.Text:=StringReplace(Src, ';', #13#10, [rfReplaceAll]);
        HasWildCards:=((Pos('*', Src) > 0)or(Pos('?', Src) > 0));

        if Files.Count = 1 then
           if not HasWildCards then begin
              if DstIsDir then Dst:=Dst + ExtractFileName(Src);
              if FileExists(Src) then
                 with FilesList.Add^do begin
                   Source:=Src;
                   Destination:=Dst;
                   Size:=FajlSajz(Src);
                 end;
              GoTo OneFile;
           end;

        if Files.Count > 0 then begin
           if not DstIsDir then begin
              Ext:=ExtractFileExt(Dst);
              Dst:=ExtractFilePath(Dst);
           end;
           for I:=0 to Files.Count-1 do begin
               Src:=Files.Strings[I];
               AddFiles(FilesList, Src, Dst, Ext);
           end;
        end;
OneFile:
     finally
        Result:=FilesList.Count;
        FreeAndNil(Files);
     end;
end;

function GetSysIconIndex(const FileName: string; Small: Boolean = true): Integer;
const siIco: array[Boolean] of Integer = (0, SHGFI_SMALLICON);
var SFI: TSHFileInfo;
begin
     SHGetFileInfo(PChar(FileName), 0, SFI, SizeOf(SFI), SHGFI_SYSICONINDEX or siIco[Small]);
     Result:=SFI.iIcon;
end;



end.


-------------
0
 
LVL 12

Expert Comment

by:Lee_Nover
ID: 7054940
ahh sorry .. forgot about all the subdirs also :)
I can add that also if it's really important :)
you can modify it yourself ... just add a check in the AddFiles function wheter an entry is a directory if so then call ParseSource again :)
0
 
LVL 27

Accepted Solution

by:
kretzschmar earned 400 total points
ID: 7055701
well, and my version (just as sceleton) :-))

procedure FindFile(PathFileName : string; IncludeSubDirs : Boolean);
var
 srec : TSearchRec;
 FHandle : integer;
 Path, FileName : String;
begin
Path := ExtractFilePath(PathFileName);
FileName := ExtractFileName(PathFileName);
// CurrentDirectory
if findfirst(PathFileName,faanyfile,srec) = 0 then
begin
  repeat
    If Not(srec.attr and fadirectory > 0) then
    begin

           // FileFound do something with it
           showmessage('Found :'+Path+SRec.Name);  // Here i do something, maybe fill a stringlist

    end;
  Until findnext(srec) <> 0;
end;
FindClose(SRec);
{ SubDirectories }
If IncludeSubDirs then
begin
  if FindFirst(Path+'*.*',FaAnyFile,Srec) = 0 then
  begin
    repeat
      // StartRecursion
      if not(Srec.Name[1] = '.') and (srec.attr and fadirectory > 0)then
        FindFile(Path + Srec.Name + '\' + FileName,IncludeSubDirs)
    Until findnext(srec) <> 0;
  end;
  FindClose(SRec);
end;
end;

to call

findfiles('c:\*.mp3',true);

meikl ;-)
0
 

Expert Comment

by:gavar
ID: 7056478
And here's my code

procedure enumFiles(filename:String);
begin
  // called once for every matching filename
end;

procedure GetFileList(Path,Filter:String);
var
  sr : TSearchRec;
begin
  if path[length(path)]<>'\' then path := path + '\';
  if FindFirst(path+filter, faAnyFile, sr) = 0 then
  begin
    if (sr.filename<>'.') or (sr.filename<>'..') then
       if sr.attr = faDirectory then getfilelist(path+sr.filename,filter) else enumfiles(path+sr.filename);
    while FindNext(sr) = 0 do
    begin
      if (sr.filename<>'.') or (sr.filename<>'..') then
         if sr.attr = faDirectory then getfilelist(path+sr.filename,filter) else enumfiles(path+sr.filename);
    end;
    FindClose(sr);
  end;
end;
0
 
LVL 10

Expert Comment

by:Jacco
ID: 7057127
A lot of code to choose from!! :-)
0
 

Author Comment

by:mdavis1982
ID: 7057925
Thank you!

Yours was the only answer that actually worked properly!  All the rest had a bug in which if the base directory contained nothing but Sub Directories, they didn't gather any files!

Thanks you so much...

It has been a real help...

Matt
0

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction The parallel port is a very commonly known port, it was widely used to connect a printer to the PC, if you look at the back of your computer, for those who don't have newer computers, there will be a port with 25 pins and a small print…
Introduction Raise your hands if you were as upset with FireMonkey as I was when I discovered that there was no TListview.  I use TListView in almost all of my applications I've written, and I was not going to compromise by resorting to TStringGrid…
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…
In a recent question (https://www.experts-exchange.com/questions/29004105/Run-AutoHotkey-script-directly-from-Notepad.html) here at Experts Exchange, a member asked how to run an AutoHotkey script (.AHK) directly from Notepad++ (aka NPP). This video…

831 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question