Fórum Buscar arquivos em qquer diretório #269980

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    BitBtn1: TBitBtn;
    ListBox1: TListBox;
    procedure BitBtn1Click(Sender: TObject);
    function RecurseDirectory(fname:string):tstringlist;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

type
PRecInfo=^TRecInfo;
Trecinfo=record
prev:PRecInfo;
fpathname:string;
srchrec:Tsearchrec;
end;

{$R *.dfm}

function TForm1.RecurseDirectory(fname:string):tstringlist;
var
    f1,f2: Tsearchrec;
    p1,tmp: PRecInfo;
    fpath, fwc: 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;

procedure TForm1.BitBtn1Click(Sender: TObject);
var
l1:Tstringlist;
begin
l1:=tstringlist.create;
listbox1.items.clear;
listbox1.Items.BeginUpdate;
l1:=RecurseDirectory(´C:\Teste.txt´);
listbox1.items.assign(l1);
freeandnil(l1);
listbox1.Items.endUpdate;
end;

end.