Поиск файлов в папках и подпапках

Вообщем проблема следующая:
Есть папка. В этой папке находатся ещё три подпапки. Нужно найти все файлы, удоволетворяющие условиям поиска, в папке, а потом во всех подпапках, с теми же условиями.
Вот что у меня получилось:
Код:
Procedure TMainForm.AddFolderToPlayList(Dir: String; Format: String; Folder: Boolean);Var Folders: TStrings;// Memo на форме I, M: Integer; SearchRec: TSearchRec;Begin M:=-1; If FindFirst(Dir + Format, faAnyFile, SearchRec) = 0 Then Begin PlayListBox.Items.Add(Dir+SearchRec.Name); While (FindNext(SearchRec) = 0) Do PlayListBox.Items.Add(Dir+SearchRec.Name); End; FindClose(SearchRec); If Folder Then Begin If FindFirst(Dir+'*', faDirectory, SearchRec) = 0 Then Begin If (SearchRec.Name<>'') And (SearchRec.Name<>'.') And (SearchRec.Name<>'..') Then Begin M:=M+1; Folders.Add(Dir+SearchRec.Name+''); End; While (FindNext(SearchRec) = 0) Do If (SearchRec.Name<>'') And (SearchRec.Name<>'.') And (SearchRec.Name<>'..') Then BeginM:=M+1;Folders.Add(Dir+SearchRec.Name+''); End; FindClose(SearchRec); For I:=0 To M Do AddFolderToPlayList(Folders.Strings[i], Format, True); End; End;End;
Но это работать не хочет. Точнее добавляет файлы только из первой папки. А дальше либо ничего не находит, либо зацикливается и вылетает.
Что в процедуре не так?
Довольно простой пример. Хочеться дать только вот эту ссылку.
http://www.programmersclub.ru/labmultimedta
Mp3-плеер
Программа для воспроизведения mp3 файлов. Для запуска программы поместите в каталог с Delphi исходником mp3 файлы и только после этого запускайте проект.
Скачать (15 кб)
Я наверное не так объяснил. Я умею искать в папке. Мне нужно организовать поиск в под папках. Т.е. есть папка : H:Music. В ней лежат папки Album1, Album2, Album3. От процедуры требуется:
1. Найти все файлы по указаному пути
2. Просканировать папку на наличие других папок
3. Запустить поиск в каждой найденной папке
1 пункт готов. Заговоздка с двумя остальными. Я уже и масив пробовал, и Memo и TStrings. Толку никакого.
В алгоритме организованна попытка рекрусии, но как-то не особо работает. Если кто знает ещё вариант решения, не откажусь его выслушать.
С папками работаешь как и сдругими файлами. маску поиска посмотри.
Никаких рекурсий не надо.
как я реализовываю
1) процедура поиска файлов.
2) передаёшь процедуре маску, получаешь массив с файлами (папки ищет также как файлы).
3) для перехода в папку используешь http://www.delphibasics.ru/ChDir.php
для возврата ChDir('..');
'..' - это должен знать ещё из доса.
Если я тебе дам код, то тебе же будет не интересно
Огромное спасибо тебе за ссылку, поиск работает лучше, но не всё сканирует. Вот что у меня получилось:
Код:
Procedure TMainForm.AddFolderToPlayList(Dir: String; Format: String; Folder: Boolean);Procedure Find(Dir: String; Format: String);Var SearchRec: TSearchRec;Begin If FindFirst(Dir + Format, faAnyFile, SearchRec) = 0 Then Begin PlayListBox.Items.Add(Dir+SearchRec.Name); While (FindNext(SearchRec) = 0) Do PlayListBox.Items.Add(Dir+SearchRec.Name); End; FindClose(SearchRec);End;Var SearchRec: TSearchRec; NextDir: String;Begin Find(Dir, Format); If Folder Then Begin If FindFirst(Dir+'*', faDirectory, SearchRec) = 0 Then Begin If (SearchRec.Name<>'') And (SearchRec.Name<>'.') And (SearchRec.Name<>'..') Then Begin ChDir('..'); // Есть смысл от этой строчки? ChDir(Dir+SearchRec.Name); GetDir(0, NextDir); Find(NextDir+'', Format); End; While (FindNext(SearchRec) = 0) Do If (SearchRec.Name<>'') And (SearchRec.Name<>'.') And (SearchRec.Name<>'..') Then BeginChDir('..'); // Есть смысл от этой строчки?ChDir(Dir+SearchRec.Name);GetDir(0, NextDir);Find(NextDir+'', Format); End; FindClose(SearchRec); End; End;End;
Я не пойму, как его заставить искать в папках которые лежат "глубже" 1 уровня (0 - задайтся переменной Dir, 1 - "глубже" Dir на одну папку, 2 - "глубже" на две и т.д.)
И ещё: Иногда вылезает ошибка IO error 267
ChDir('..'); - используют для возврата из папки назад.
Ничего не получилось. Добился тока вылета постоянной ошибки "File not found".
Дай, пожалуйста, код, чтобы я посмотрел и сделал по аналогии.
Вот можеш пользоваться, а можешь глянуть как я это сделал:
{ Public declarations }
sc:TScan;
procedure onscan(path:string;Dan:TSearchRec;f:boolean);
....
procedure TForm1.FormCreate(Sender: TObject);
begin
sc:=TScan.Create;
sc.Path:='Путь';
sc.Mask:='*.exe;*.txt';
sc.RescueDir:=true;//сканировать вложенные папки
sc.FirstDir:=true;//сначала ищутся папки
sc.ShowFile:=true;//находить файлы
sc.OnFound:=onscan;
sc.Scan:=true;//начать поиск, в любой момент изменяешь на ложь и поиск прекращается
sc.Destroy;
end;
procedure TForm1.onscan(path: string; Dan: TSearchRec; f: boolean);
begin
path-путь
f-файл или нет
dan - инфа о файле
end;
а вот и самое главное:
unit Scan;
interface
uses SysUtils,str,Dialogs;
const
faOnlyFile = $1 or $2 or $4 or $8 or $20;
Type
procStringSearcrecBool = procedure(path:string;
DN:tsearchrec;Fil:boolean) of object;
searchrec=tsearchrec;
TScan = class
private
FScan,fd,frd,sf:boolean;
FPath: string;
Ffound: procStringSearcrecBool;
FMask: string;
procedure SetScan(const Value: boolean);
procedure SSS(ph:string);
procedure SetMask(const Value: string);
procedure Setpath(const Value: string);
public
property Path:string read FPath write setPath;
property Mask:string read FMask write SetMask;
property Scan:boolean read FScan write SetScan;
property RescueDir:boolean read Frd write frd;
property FirstDir:boolean read fd write fd;
property ShowFile:boolean read sf write sf;
property OnFoundrocStringSearcrecbool read Ffound write Ffound;
constructor Create;
destructor Destroy; override;
end;
implementation
{ TScan }
constructor TScan.Create;
begin inherited;
mask:='*.*';sf:=true;end;
destructor TScan.Destroy;
begin inherited;end;
procedure TScan.SetMask(const Value: string);
begin if FScan then exit;
FMask := Value;
if Str_EndPos(FMask)<>';'then
FMask:=FMask+';';
if(FMask=';')or(pos('*.*',fmask)>0)then FMask:='*.*;';end;
procedure TScan.Setpath(const Value: string);
begin FPath:=Str_Replacement(value+'','\','');end;
procedure TScan.SetScan(const Value: boolean);
begin FScan := Value;
if value then sss(path);
fScan:=false;
end;
procedure TScan.SSS;
var r:tsearchrec;m:string;
function delm:string;{Следующая маска}
begin result:=Str_CopyToFirst(m,';');
if result=''then exit;
m:=Str_DelToFirst(m,';');
delete(m,1,1);end;{Delm}
procedure sfile(pah:string);{Поиск файлов}
var mm:string;
Begin if not sf then exit;
m:=mask;mm:=delm;
while(mm<>'')and(FScan)do begin
if FindFirst(ph+mm,FAonlyfile,r)=0then
repeat if Assigned(ffound)then
ffound(pah,r,true);
until(FindNext(r)<>0)or not FScan;
mm:=delm;end;End;{sfile}
procedure sdir(pah:string);{Поиск дирректорий}
const pp=faanyfile;
var d:string;
Begin if FindFirst(pah+'*.*',pp,r)=0then
repeat if not FScan then exit;
if((r.Attr and fadirectory)<>0)
and(r.Name<>'.')and(r.Name<>'..')then begin
if Assigned(ffound)then Ffound(pah,r,false);
if RescueDir then sss(pah+r.Name);end;
until (FindNext(r)<>0);End;{sdir}
begin if not FScan then exit;
if Str_EndPos(ph)<>''then
ph:=ph+'';
if fd then sdir(ph);
sfile(Ph);
if not fd then sdir(ph);
FindClose(r);
end;
end.
попробйу вот так
Код:
procedure ScanDir(StartDir: string; Mask: string; List: TStrings);var SearchRec: TSearchRec;begin if Mask = '' then Mask := '*.*'; if StartDir[Length(StartDir)] <> '' then StartDir := StartDir + ''; if FindFirst(StartDir + Mask, faAnyFile, SearchRec) = 0 then begin repeat Application.ProcessMessages; if (SearchRec.Attr and faDirectory) <> faDirectory then List.Add(StartDir + SearchRec.Name) else if (SearchRec.Name <> '..') and (SearchRec.Name <> '.')thenbegin List.Add(StartDir + SearchRec.Name + ''); ScanDir(StartDir + SearchRec.Name + '', Mask, List); end;until FindNext(SearchRec) <> 0;FindClose(SearchRec);end;end;
Спасибо, что откликнулись
2mrandrey:
Код сложный, поэтому разбираться в нём буду на выходных.
Как я понял, это модуль.
И тут без 100 грамм точно не разберёшся
2dron-s:
Этот код у меня не заработал, но суть ясна. Буду копать в этом направлении. Мож к концу недели сделаю.
P.S. А для чего нужен List: TStrings ? Не проще сразу добавлять в нужное место.
Ещё мне не понятна эта строка:
Код:
if (SearchRec.Attr and faDirectory) <> faDirectory then
(Я догадываюсь, что она служит для определения файл это или папка)
это строка как раз таки и просматривает текущие директории
List:TString - в эту переменную записывается список всех файлов...
почему у тебя код не заработал? какие ошибки выдал?
Ошибка следующая:
=========
Access violation at adress 00414591 in module "Player.exe". Read of asress 0000BD25.
=========
Ошибка выскакивает сразу же.
Код который вызывает процедуру:
Код:
procedure TAddForm.AddButClick(Sender: TObject);Var pwRoot: PWideChar; Dir: String; PlayList: TStrings;begin GetMem(pwRoot, (Length(Root)+1)*2); pwRoot:=StringToWideChar(Root, pwRoot, MAX_PATH*2); If not SelectDirectory('Выберите папку в которой находятся файлы', pwRoot, Dir) Then Dir:='' Else Dir:=Dir+''; MainForm.ScanDir(Dir, '*.mp3', PlayList); MainForm.PlayListBox.Items.AddStrings(PlayList); Close;end;
Может быть в нём ошибка.
И ещё:
Код:
if StartDir[Length(StartDir)-1] <> '' then
Разве еденица не должна отниматся?
Вот юзес с коментариями:
unit Search;
interface
uses Windows, Classes;
function SearchInFolder(folder, mask: String; flags: DWORD;
names: TStrings; addpath: Boolean = False): Boolean;
function SearchInTree(folder, mask: String; flags: DWORD;
names: TStrings; addpath: Boolean = False): Boolean;
implementation
//Функция возвращает True, если атрибуты (attrs) файла или папки
//соответствуют режиму поиска (flags)
//Реализует нестрогую проверку (принимаются файлы и каталоги, имеющие
//искомые атрибуты, независимо от наличия у них других дополнительных
//атрибутов, которые не заданы при поиске).
//Для реализации строгой проверки можно изменить
//MatchAttrs := (flags and attrs) = flags; на
//MatchAttrs := (flags = attrs);
function MatchAttrs(flags, attrs: DWORD): Boolean;
begin
MatchAttrs := (flags and attrs) = flags;
end;
//Поиск по маске и атрибутам в заданной папке (если найден хоть один файл
//или каталог, то возвращается True).
//Список names заполняется именами найденных файлов и папок
function SearchInFolder(folder, mask: String; flags: DWORD;
names: TStrings; addpath: Boolean = False): Boolean;
var
hSearch: THandle;
FindData: WIN32_FIND_DATA;
strSearchPath: String;
bRes: Boolean; //Если равен True, то нашли хотя бы один файл или каталог
begin
strSearchPath := folder + '' + mask;
bRes := False;
//Начинаем поиск
hSearch := FindFirstFile(PAnsiChar(strSearchPath), FindData);
if (hSearch <> INVALID_HANDLE_VALUE) then
begin
//Ищем все похожие элементы (информация о первом элементе уже
//записана в FindData функцией FindFirstFile)
repeat
if (String(FindData.cFileName) <> '..') and
(String(FindData.cFileName) <> '.') then //Пропускаем . и ..
begin
if MatchAttrs(flags, FindData.dwFileAttributes) then
begin
//Нашли подходящий объект
if addpath then
names.Add(folder + '' + FindData.cFileName)
else
names.Add(FindData.cFileName);
bRes := True;
end;
end;
until FindNextFile(hSearch, FindData) = FALSE;
//Заканчиваем поиск
FindClose(hSearch);
end;
SearchInFolder := bRes;
end;
//Функция поиска в дереве каталогов с заданным корневым каталогом (folder)
//В список записываются полные пути найденных файлов и папок
function SearchInTree(folder, mask: String; flags: DWORD;
names: TStrings; addpath: Boolean = False): Boolean;
var
hSearch: THandle;
FindData: WIN32_FIND_DATA;
bRes: Boolean; //Если равен True, то нашли хотя бы один файл или каталог
begin
//Осуществляем поиск в текущей папке
bRes := SearchInFolder(folder, mask, flags, names, addpath);
//Продолжим поиск в каждом из подкаталогов
hSearch := FindFirstFile(PAnsiChar(folder + '*'), FindData);
if (hSearch <> INVALID_HANDLE_VALUE) then
begin
repeat
if (String(FindData.cFileName) <> '..') and
(String(FindData.cFileName) <> '.') then //Пропускаем . и ..
begin
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0)
then
//Нашли подкаталог - выполним в нем поиск
if SearchInTree(folder + '' + String(FindData.cFileName),
mask, flags, names, addpath)
then
bRes := True;
end;
until FindNextFile(hSearch, FindData) = FALSE;
FindClose(hSearch);
end;
SearchInTree := bRes;
end;
end.
unit Search;
interface
uses Windows, Classes;
function SearchInFolder(folder, mask: String; flags: DWORD;
names: TStrings; addpath: Boolean = False): Boolean;
function SearchInTree(folder, mask: String; flags: DWORD;
names: TStrings; addpath: Boolean = False): Boolean;
implementation
//Функция возвращает True, если атрибуты (attrs) файла или папки
//соответствуют режиму поиска (flags)
//Реализует нестрогую проверку (принимаются файлы и каталоги, имеющие
//искомые атрибуты, независимо от наличия у них других дополнительных
//атрибутов, которые не заданы при поиске).
//Для реализации строгой проверки можно изменить
//MatchAttrs := (flags and attrs) = flags; на
//MatchAttrs := (flags = attrs);
function MatchAttrs(flags, attrs: DWORD): Boolean;
begin
MatchAttrs := (flags and attrs) = flags;
end;
//Поиск по маске и атрибутам в заданной папке (если найден хоть один файл
//или каталог, то возвращается True).
//Список names заполняется именами найденных файлов и папок
function SearchInFolder(folder, mask: String; flags: DWORD;
names: TStrings; addpath: Boolean = False): Boolean;
var
hSearch: THandle;
FindData: WIN32_FIND_DATA;
strSearchPath: String;
bRes: Boolean; //Если равен True, то нашли хотя бы один файл или каталог
begin
strSearchPath := folder + '' + mask;
bRes := False;
//Начинаем поиск
hSearch := FindFirstFile(PAnsiChar(strSearchPath), FindData);
if (hSearch <> INVALID_HANDLE_VALUE) then
begin
//Ищем все похожие элементы (информация о первом элементе уже
//записана в FindData функцией FindFirstFile)
repeat
if (String(FindData.cFileName) <> '..') and
(String(FindData.cFileName) <> '.') then //Пропускаем . и ..
begin
if MatchAttrs(flags, FindData.dwFileAttributes) then
begin
//Нашли подходящий объект
if addpath then
names.Add(folder + '' + FindData.cFileName)
else
names.Add(FindData.cFileName);
bRes := True;
end;
end;
until FindNextFile(hSearch, FindData) = FALSE;
//Заканчиваем поиск
FindClose(hSearch);
end;
SearchInFolder := bRes;
end;
//Функция поиска в дереве каталогов с заданным корневым каталогом (folder)
//В список записываются полные пути найденных файлов и папок
function SearchInTree(folder, mask: String; flags: DWORD;
names: TStrings; addpath: Boolean = False): Boolean;
var
hSearch: THandle;
FindData: WIN32_FIND_DATA;
bRes: Boolean; //Если равен True, то нашли хотя бы один файл или каталог
begin
//Осуществляем поиск в текущей папке
bRes := SearchInFolder(folder, mask, flags, names, addpath);
//Продолжим поиск в каждом из подкаталогов
hSearch := FindFirstFile(PAnsiChar(folder + '*'), FindData);
if (hSearch <> INVALID_HANDLE_VALUE) then
begin
repeat
if (String(FindData.cFileName) <> '..') and
(String(FindData.cFileName) <> '.') then //Пропускаем . и ..
begin
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0)
then
//Нашли подкаталог - выполним в нем поиск
if SearchInTree(folder + '' + String(FindData.cFileName),
mask, flags, names, addpath)
then
bRes := True;
end;
until FindNextFile(hSearch, FindData) = FALSE;
FindClose(hSearch);
end;
SearchInTree := bRes;
end;
end.
Там две функции, одна ищет на одном уровне
function SearchInFolder(folder, mask: String; flags: DWORD;
names: TStrings; addpath: Boolean = False): Boolean;
другая - по всему дереву каталогов ниже:
function SearchInTree(folder, mask: String; flags: DWORD;
names: TStrings; addpath: Boolean = False): Boolean;
вынул из программы.
Поиск папок, заметь там есть фильтры на отсечение некоторых папок.
Вызови процедуру. poiskpapki;
и получишь, все папки в этом массиве - Directory, не забудь его сделать глобальным и переменную pap тоже.
Код:
procedure poiskpapki;label a;varSearchRec: TSearchRec;begin pap:=-1;if FindFirst('*', faAnyFile, SearchRec) = 0 thenrepeat if (SearchRec.Attr and faDirectory) = faDirectory then// каталоги .. и . тоже каталоги,// но в них входить не надо !!!if SearchRec.Name[1] <> '.' then begin if (SearchRec.Name='temp')or(SearchRec.Name='content') or(SearchRec.Name='Thumbs.db')or(SearchRec.Name='index.html')or(SearchRec.Name='text.txt')or(SearchRec.Name='key.txt')then goto a;pap:=pap+1;setlength(directory,pap+1);Directory[pap]:=SearchRec.Name; a: end;until FindNext(SearchRec) <> 0;end;
А это файлы ищет. тоже есть фильры принцип действия такой же.
Вынцл код из программи, потому возможно, потребуеться его адаптировать под твою программу.
Код:
procedure poiskpapki3;label r;varSearchRec: TSearchRec;begin pap3:=-1;if FindFirst('*.*', faAnyFile, SearchRec) = 0 thenrepeat if SearchRec.Name[1] <> '.' then begin if (SearchRec.Name='temp')or(SearchRec.Name='content') or(SearchRec.Name='Thumbs.db')or(SearchRec.Name='index.html') then goto r;pap3:=pap3+1;setlength(directory3,pap3+1);Directory3[pap3]:=SearchRec.Name; r: end;until FindNext(SearchRec) <> 0;
Пример использования -
Код:
poiskpapki;for i:=0 to pap dobeginChDir( directory[i]);memo3.Lines.SaveToFile(directory[i]+inttostr(chislo_stranic)+'.php'); ChDir('..');end;
format c
а что отладчик показывает? в каком месте косяк?
попробуй вот так вот использовать процедуру
Код:
ListBox1.Items.Clear; ScanDir('c:', '', ListBox1.Items); Label1.Caption := IntToStr(ListBox1.Items.Count);
по крайней мере у меня работает
2dron-s:
Отладчик ничего не показывает, т.к. ошибки не возникает, но файлы в подпапках не ищет. Ищет только файлы в самой папке.
Оценив выше сказанную информацию сварганил новую прцедуру. Но она всё равно не работает
Выдаёт ошибку:
=========
I/O error 267
=========
Процедура:
Код:
Procedure TMainForm.AddFolderToPlayList(Format: String; Folder: Boolean);Var SearchRec: TSearchRec;begin If FindFirst(Format, faAnyFile, SearchRec) = 0 Then PlayListBox.Items.Add(SearchRec.Name); While FindNext(SearchRec) = 0 Do PlayListBox.Items.Add(SearchRec.Name); FindClose(SearchRec); If Folder Then Begin If FindFirst('*', faDirectory, SearchRec) = 0 Then If (SearchRec.Name<>'') And (SearchRec.Name<>'.') And (SearchRec.Name<>'..') Then Begin ChDir(SearchRec.Name+''); AddFolderToPlayList(Format, True); ChDir('..'); End; While FindNext(SearchRec) = 0 Do Begin ChDir(SearchRec.Name+''); AddFolderToPlayList(Format, True); ChDir('..'); End; FindClose(SearchRec); End;End;
Вызов:
Код:
Var pwRoot: PWideChar; Dir: String;begin GetMem(pwRoot, (Length(Root)+1)*2); pwRoot:=StringToWideChar(Root, pwRoot, MAX_PATH*2); If not SelectDirectory('Выберите папку в которой находятся файлы', pwRoot, Dir) Then Dir:='' Else Dir:=Dir+''; ChDir(Dir); MainForm.ScanDir(Dir, '*.mp3', PlayList.Items); //PlayList это ListBox на формеEnd;
Объясните подробно, по шагам, какой нужен алгоритм, и почему этот не работает
Если надо, могу прислать полный код программы.
я конечно толком не разобрался но меня пугает немного две вещи
1. Dir:=''
Else Dir:=Dir+''; Вроде селектдира вернет со слешем (возможно ошибаюсь)
2. ChDir(Dir) - незнаю, были у меня с ним проблемы не подружились, больше доверяю Апи Windows.SetCurrentDirectory
а так по коду вроде все хокей, да и чего там такого сложного в поиске то вот код для удаления всех подпапок и фалов в них указаной папки смотрите
procedure DeleteFiles(Dira:String);
var
rc:tsearchrec;
begin
if dira[length(dira)] <> '' then
dira := dira + '';
if findfirst(dira+'*',faanyfile,rc) = 0 then
repeat
if rc.Attr and fadirectory = 0 then
begin
deletefile(dira+rc.Name);
end
else
if pos('.',rc.Name) = 0 then
begin
DeleteFiles(dira+rc.Name);
end;
until
findnext(rc) <> 0;
findclose(rc);
removedir(dira);
end;
собсно рекурсия ))) а так не получится надо отдельную процедуру писать
Кто нить знает как сделать так чтобы в лист бокс можно было бы претаскивать мп3 файлы ?(Delphi)примерно так же как в винампе