Fazendo um busca de arquivo em TODO O HD
Preciso de uma rotina que encontre uma arquivo localizado dentro do meu HD. por exemplo so vou passar o nome do arquivo ex: 'Inicio.txt', como se fosse a pesquisa do windows, so passo o nome do arquivo e retorna o caminho do mesmo. Como posso fa zer um busca de arquivo EM TODO O HD? Eu dei uma busca na internet e encontrei essa rotina:
Interface
type
PRecInfo=^TRecInfo;
Trecinfo=record
prev:PRecInfo;
fpathname:string;
srchrec:Tsearchrec;
end;
implememtation function TForm1.RecurseDirectory(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; //Chame a funcao deste jeito: procedure TForm1.Button1Click(Sender: TObject);
var
l1:Tstringlist;
begin
l1:=tstringlist.create;
listbox1.items.clear;
listbox1.Items.BeginUpdate;
l1:=recursedirectory1('C:*.exe');
listbox1.items.assign(l1);
freeandnil(l1);
listbox1.Items.endUpdate;
end;
Essa Rotina fucionou pefeitamente bem, porém ela só fuciona no windows XP e eu queria que fucionasse também no WINDOWS 7. Espero q vocês mi ajudem. Obrigado...
PRecInfo=^TRecInfo;
Trecinfo=record
prev:PRecInfo;
fpathname:string;
srchrec:Tsearchrec;
end;
implememtation function TForm1.RecurseDirectory(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; //Chame a funcao deste jeito: procedure TForm1.Button1Click(Sender: TObject);
var
l1:Tstringlist;
begin
l1:=tstringlist.create;
listbox1.items.clear;
listbox1.Items.BeginUpdate;
l1:=recursedirectory1('C:*.exe');
listbox1.items.assign(l1);
freeandnil(l1);
listbox1.Items.endUpdate;
end;
Essa Rotina fucionou pefeitamente bem, porém ela só fuciona no windows XP e eu queria que fucionasse também no WINDOWS 7. Espero q vocês mi ajudem. Obrigado...
Jose Pereira
Curtidas 0
Respostas
Guilherme Marini
13/03/2011
cara,eu consigui um codigo que faça isso olha
unit Unit5;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, unit7;
type
TForm5 = class(TForm)
BProcurar: TButton;
LEncontrado: TListBox;
LProcurando: TListBox;
procedure BProcurarClick(Sender: TObject);
private
procedure FindFiles(FilesList: TStringList; StartDir, Mascara: string; IncludeRoot:boolean);
{ Private declarations }
public
{ Public declarations }
end;
var
Form5: TForm5;
teste: MinhaThread;
implementation
{$R *.dfm}
procedure TForm5.BProcurarClick(Sender: TObject);
var FilesList : TStringList;
begin
FilesList := TStringList.Create;
findfiles(FilesList,'c:','Arquivo.txt',true);
LEncontrado.Items.Assign(Fileslist);
end;
procedure TForm5.FindFiles(FilesList: TStringList; StartDir, Mascara: string; IncludeRoot:boolean);
var
SR: TSearchRec;
ListaDir: TStringList;
IsFound: Boolean;
i,l: integer;
begin
if length(StartDir)<>0 then
if StartDir[length(StartDir)] <> '\' then
begin
StartDir := StartDir + '\';
end;
IsFound :=FindFirst(StartDir+Mascara, faAnyFile-faDirectory, SR) = 0;
while IsFound do begin
FilesList.Add(StartDir + SR.Name);
IsFound := FindNext(SR) = 0;
end;
FindClose(SR);
if IncludeRoot=true then
begin
// Cria lista de subdirectorios
ListaDir := TStringList.Create;
IsFound := FindFirst(StartDir+'*.*', faAnyFile, SR) = 0;
while IsFound do begin
if ((SR.Attr and faDirectory)<>0) and
(SR.Name[1] <> '.') and (SR.Name <> 'Windows') then
ListaDir.Add(StartDir + SR.Name);
LProcurando.Items.Assign(ListaDir);
IsFound := FindNext(SR) = 0;
end;
FindClose(SR);
// Procura dentro da lista
for i := 0 to ListaDir.Count - 1 do
FindFiles(FilesList, ListaDir[i], Mascara,includeroot);
ListaDir.Free;
end;
end;
end.
crie duas tListBox, uma chamando LEncontrado e outra LProcurando e um botao para executar o comando. a Rotina eh
FindFiles(FilesList,pasta onde vai procurar, no caso c:,Arquivo a ser procurado,True);
espero ter ajudado, o problema dessa rotina eh que ela trava o programa qnd voce começa a procurar, e soh destrava ao termino dela, estou procurando uma forma de fazer usando threads.
unit Unit5;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, unit7;
type
TForm5 = class(TForm)
BProcurar: TButton;
LEncontrado: TListBox;
LProcurando: TListBox;
procedure BProcurarClick(Sender: TObject);
private
procedure FindFiles(FilesList: TStringList; StartDir, Mascara: string; IncludeRoot:boolean);
{ Private declarations }
public
{ Public declarations }
end;
var
Form5: TForm5;
teste: MinhaThread;
implementation
{$R *.dfm}
procedure TForm5.BProcurarClick(Sender: TObject);
var FilesList : TStringList;
begin
FilesList := TStringList.Create;
findfiles(FilesList,'c:','Arquivo.txt',true);
LEncontrado.Items.Assign(Fileslist);
end;
procedure TForm5.FindFiles(FilesList: TStringList; StartDir, Mascara: string; IncludeRoot:boolean);
var
SR: TSearchRec;
ListaDir: TStringList;
IsFound: Boolean;
i,l: integer;
begin
if length(StartDir)<>0 then
if StartDir[length(StartDir)] <> '\' then
begin
StartDir := StartDir + '\';
end;
IsFound :=FindFirst(StartDir+Mascara, faAnyFile-faDirectory, SR) = 0;
while IsFound do begin
FilesList.Add(StartDir + SR.Name);
IsFound := FindNext(SR) = 0;
end;
FindClose(SR);
if IncludeRoot=true then
begin
// Cria lista de subdirectorios
ListaDir := TStringList.Create;
IsFound := FindFirst(StartDir+'*.*', faAnyFile, SR) = 0;
while IsFound do begin
if ((SR.Attr and faDirectory)<>0) and
(SR.Name[1] <> '.') and (SR.Name <> 'Windows') then
ListaDir.Add(StartDir + SR.Name);
LProcurando.Items.Assign(ListaDir);
IsFound := FindNext(SR) = 0;
end;
FindClose(SR);
// Procura dentro da lista
for i := 0 to ListaDir.Count - 1 do
FindFiles(FilesList, ListaDir[i], Mascara,includeroot);
ListaDir.Free;
end;
end;
end.
crie duas tListBox, uma chamando LEncontrado e outra LProcurando e um botao para executar o comando. a Rotina eh
FindFiles(FilesList,pasta onde vai procurar, no caso c:,Arquivo a ser procurado,True);
espero ter ajudado, o problema dessa rotina eh que ela trava o programa qnd voce começa a procurar, e soh destrava ao termino dela, estou procurando uma forma de fazer usando threads.
GOSTEI 0