unit DSFindFilesCls;
(* FindFiles - Klasse zum Durchsuchen von Ordnern
basierend auf der Entwicklung von
Michael Puff [[url]http://www.michael-puff.de][/url], himitsu, omata,
modifiziert/erweitert von Dirk S. aka Tryer
Im Forum unter [url]http://www.delphipraxis.net/topic177139,0,asc,15.html[/url]
"Klasse für FindFirstFile/FindNextFile"
Meine Änderungen:
- einheitlich "Folder" an Stelle von "Directory" verwendet
- SysUtils eingebunden für Exception / DirectoryExists
TODO: ggf. Funktionen anderweitig implementieren/ersetzen
- Bei ScanSubFolders = False wird OnFindFolder/OnFindFolders für die
enthaltenen Unterverzeichnisse von RootFolder ausgelöst.
- Nur einmalige Korrektur von Rootfolder in Find(), da abschliessendes '\' in
Search() sichergestellt ist
- Laufzeitreduzierung durch gemeinsame Suchschleife für Verzeichnise und Dateien
da für die Suche nach Verzeichnissen eh vollständig durchsucht wird.
Die Funktion MatchesMask() wird zur Auswahl der Dateien genutzt
TODO: MatchesMask und somit Unit Masks ersetzen
- "gebündelte Events" (s.u.) natürlich auch bei synchroner Ausführung
- Duration: simple Laufzeitanalyse per GetTickCount
>>>>>>>>>>>>>>>>>> Asynchrone Ausführung <<<<<<<<<<<<<<<<<<<<<<<
-> FindAsync(RootFolder: string; SyncEvents: Boolean = True)
- Abbruch von außen mit TFindFiles.Abort;
- an/abwählbarer Synchronisierung von den OnFindFolder/OnFindFile/OnFolderUp
über optionalen Parameter "SyncEvents"
(Standard "True" -> Events werden mit dem VCL-MainThread synchronisiert
Abschaltbar um z.b. VCL-unabhängig eine TStringList zu füllen
- Stets synchronisierte Events "OnBeginScan" und "OnEndScan" um
beispielsweise eine (asynchron) erstellte Stringliste in ein VCL-Objekt
(z.B.TMemo) zu übernehmen bzw. Begin-/EndUpdate von TStrings zu nutzen
- Ohne genauere Analyse habe ich das Setzen der Events und der Maske
während der asynchronen Ausführung erstmal per TryLock verhindert.
TODO: Konzept überprüfen, ggf. parallele Aufrufe ermöglichen
- gebündelte Events: OnFindFiles() und OnFindFolders() (Plural!):
- Unabhängig vom Flag "SyncEvents" werden diese Events immer
synchronisiert ausgeführt da die sinnvolle Auswertung sowieso nur
"threadsicher" möglich ist.
- Hier werden maximal <MaxEventListSize> Dateien/Verzeichnisse gesammelt
und dann einmalig in OnFindFiles/OnFindFolders zur Verfügung gestellt,
d.h. es stehen immer die seit dem letzten Event hinzugekommenen Daten
zur Verfügung ("FFiles.Clear" nach OnFindFiles).
MaxEventListSize = 128 scheint auf meinem Rechner praktikabel.
MaxEventListSize <= 0 setzt die Länge auf Classes.MaxListSize
- In diesen Events stehen keine erweiterten Daten
(TWin32FindData) zur Verfügung.
TODO: Sinn/Unsinn der Exceptions prüfen
TODO: ggf. Kommentare / Dokumentation / Beispielprojekt
*)
interface
uses
Windows, Classes, SysUtils, Masks;
type
TFindFiles =
class;
//Events für einzelne Dateien/Verzeichnisse
TFindFileEvent =
procedure(Filename:
string;
const Info: TWin32FindData;
var Cancel: Boolean)
of object;
TFindFolderEvent =
procedure(Folder:
string;
const Info: TWin32FindData;
var Cancel: Boolean;
var SkipFolder: Boolean)
of object;
//Gebündelte Events
TFindFilesEvent =
procedure(Filenames: TStrings;
var Cancel: Boolean)
of object;
TFindFoldersEvent =
procedure(Folders: TStrings;
var Cancel: Boolean)
of object;
TFolderUpEvent =
procedure(FromFolder, ToFolder:
string;
var Cancel: Boolean)
of object;
TEndScanEvent =
procedure(Sender: TFindFiles;
const Canceled: Boolean)
of object;
TBeginScanEvent =
procedure(Sender: TFindFiles)
of object;
TFindFilesThread =
class(TThread)
private
FParent: TFindFiles;
protected
procedure Execute;
override;
public
constructor Create(Parent: TFindFiles);
end;
TFindFiles =
class
private
FLock: TRTLCriticalSection;
FScanSubFolders: Boolean;
FMask:
string;
FRootFolder:
string;
FThread: TFindFilesThread;
FOnFindFile: TFindFileEvent;
FOnFindFolder: TFindFolderEvent;
FOnFolderUp: TFolderUpEvent;
FCancel: Boolean;
FSkipDir: Boolean;
FAsync: Boolean;
FSyncEvents: Boolean;
FOnBeginScan: TBeginScanEvent;
FOnEndScan: TEndScanEvent;
FFromFolder:
string;
FToFolder:
string;
FFilename:
string;
FFiles: TStringList;
FFolders: TStringList;
FFindData: TWin32FindData;
FOnFindFolders: TFindFoldersEvent;
FOnFindFiles: TFindFilesEvent;
FMaxEventListSize: Integer;
FDuration: Cardinal;
FTicks: Cardinal;
procedure SetOnBeginScan(
const Value: TBeginScanEvent);
procedure SetOnFolderUp(
const Value: TFolderUpEvent);
procedure SetOnEndScan(
const Value: TEndScanEvent);
procedure SetOnFindFolder(
const Value: TFindFolderEvent);
procedure SetOnFindFile(
const Value: TFindFileEvent);
procedure SetOnFindFolders(
const Value: TFindFoldersEvent);
procedure SetOnFindFiles(
const Value: TFindFilesEvent);
procedure SetMaxEventListSize(
const Value: Integer);
procedure SetEvent(
var Event: TMethod;
const Value: TMethod);
procedure SetMask(
const Value:
string);
protected
procedure Search(RootFolder:
string);
procedure DoProc(Proc: TThreadMethod; ForceSync: Boolean);
procedure Lock;
function TryLock: Boolean;
procedure Unlock;
procedure AddDirToDirList;
procedure AddFileToFileList;
procedure DoFolderUp;
procedure DoFindFile;
procedure DoFindFolder;
procedure DoFindFiles;
procedure DoFindFolders;
procedure DoEndScan;
public
constructor Create;
destructor Destroy;
override;
procedure Find(RootFolder:
string);
procedure FindAsync(RootFolder:
string; SyncEvents: Boolean = True);
procedure Abort;
property ScanSubFolders: Boolean
read FScanSubFolders
write FScanSubFolders;
property Mask:
string read FMask
write SetMask;
property MaxEventListSize: Integer
read FMaxEventListSize
write SetMaxEventListSize;
property Duration: Cardinal
read FDuration;
property OnBeginScan: TBeginScanEvent
read FOnBeginScan
write SetOnBeginScan;
property OnEndScan: TEndScanEvent
read FOnEndScan
write SetOnEndScan;
property OnFindFile: TFindFileEvent
read FOnFindFile
write SetOnFindFile;
property OnFindFolder: TFindFolderEvent
read FOnFindFolder
write SetOnFindFolder;
property OnFindFiles: TFindFilesEvent
read FOnFindFiles
write SetOnFindFiles;
property OnFindFolders: TFindFoldersEvent
read FOnFindFolders
write SetOnFindFolders;
property OnFolderUp: TFolderUpEvent
read FOnFolderUp
write SetOnFolderUp;
end;
implementation
{ TFindFiles }
constructor TFindFiles.Create;
begin
inherited Create;
InitializeCriticalSection(FLock);
FScanSubfolders := False;
FFolders := TStringList.Create;
FFiles := TStringList.Create;
FMaxEventListSize := -1;
FMask := '
*.*';
end;
procedure TFindFiles.Search(RootFolder:
string);
var
wfd: TWin32FindData;
hFile: THandle;
begin
if not FCancel
then
begin
hFile := FindFirstFile(PChar(RootFolder + '
*'), wfd);
if hFile <> INVALID_HANDLE_VALUE
then
try
repeat
if (wfd.dwFileAttributes
and FILE_ATTRIBUTE_DIRECTORY <> 0)
then
begin // Verzeichnisse
if (wfd.cFileName[0] <> '
.')
then
begin
FSkipDir := False;
FFindData := wfd;
FFilename := RootFolder + wfd.cFileName;
DoProc(DoFindFolder, False);
AddDirToDirList;
if FScanSubFolders
and not FCancel
and not FSkipDir
then
begin
Search(RootFolder + wfd.cFileName + '
\');
FFromFolder := RootFolder + wfd.cFileName + '
\';
FToFolder := RootFolder;
DoProc(DoFolderUp, False);
end;
end
end else
begin // Dateien
if Assigned(FOnFindFile)
or Assigned(FOnFindFiles)
and
MatchesMask(wfd.cFileName, FMask)
then
begin
FFilename := RootFolder + wfd.cFileName;
FFindData := wfd;
DoProc(DoFindFile, False);
AddFileToFileList;
end;
end;
until FCancel
or not FindNextFile(hFile, wfd);
finally
Windows.FindClose(hFile);
end;
end;
end;
procedure TFindFiles.Find(RootFolder:
string);
begin
if not DirectoryExists(RootFolder)
then
raise Exception.Create(
'
TFindFiles.Find: Verzeichnis "' + RootFolder + '
" existiert nicht!');
if TryLock
then //sicherstellen das Thread nicht mehr läuft
begin
try
FTicks := GetTickCount;
FDuration := 0;
FCancel := False;
FAsync := False;
FSyncEvents := False;
FRootFolder := IncludeTrailingPathDelimiter(RootFolder);
FFolders.Clear;
FFiles.Clear;
if Assigned(FOnBeginScan)
then
FOnBeginScan(Self);
try
Search(FRootFolder);
//ggf. Listenreste ausgeben
if FFolders.Count > 0
then
DoFindFolders;
if FFiles.Count > 0
then
DoFindFiles;
FDuration := GetTickCount - FTicks;
finally
if Assigned(FOnEndScan)
then
FOnEndScan(Self, FCancel);
end;
finally
Unlock;
end;
end else
raise Exception.Create(
'
TFindFiles.Find() darf nicht während der Suche aufgerufen werden');
end;
procedure TFindFiles.FindAsync(RootFolder:
string; SyncEvents: Boolean = True);
begin
if not DirectoryExists(RootFolder)
then
raise Exception.Create(
'
TFindFiles.FindAsync: Verzeichnis "' + RootFolder + '
" existiert nicht!');
if TryLock
then
begin
try
FTicks := GetTickCount;
FDuration := 0;
FCancel := False;
FAsync := True;
FSyncEvents := SyncEvents;
FRootFolder := IncludeTrailingPathDelimiter(RootFolder);
FFolders.Clear;
FFiles.Clear;
if Assigned(FOnBeginScan)
then
FOnBeginScan(Self);
if Assigned(FThread)
then
FThread.Free;
//Versuch FThread.Resume schlägt fehl?! Wohl kein "Neustart" mgl.
FThread := TFindFilesThread.Create(Self);
finally
Unlock;
end;
end else
raise Exception.Create(
'
TFindFiles.FindAsync() darf nicht während der Suche aufgerufen werden');
end;
procedure TFindFiles.Lock;
begin
EnterCriticalSection(FLock);
end;
procedure TFindFiles.Unlock;
begin
LeaveCriticalSection(FLock);
end;
destructor TFindFiles.Destroy;
begin
if Assigned(FThread)
then
begin
if not FThread.Terminated
then
begin
FCancel := True;
FThread.WaitFor;
end;
FThread.Free;
FThread :=
nil;
end;
FFiles.Free;
FFolders.Free;
DeleteCriticalSection(FLock);
inherited Destroy;
end;
procedure TFindFiles.SetOnBeginScan(
const Value: TBeginScanEvent);
begin
SetEvent(TMethod(FOnBeginScan), TMethod(Value));
end;
procedure TFindFiles.SetOnFolderUp(
const Value: TFolderUpEvent);
begin
SetEvent(TMethod(FOnFolderUp), TMethod(Value));
end;
procedure TFindFiles.SetOnEndScan(
const Value: TEndScanEvent);
begin
SetEvent(TMethod(FOnEndScan), TMethod(Value));
end;
procedure TFindFiles.SetOnFindFolder(
const Value: TFindFolderEvent);
begin
SetEvent(TMethod(FOnFindFolder), TMethod(Value));
end;
procedure TFindFiles.SetOnFindFile(
const Value: TFindFileEvent);
begin
SetEvent(TMethod(FOnFindFile), TMethod(Value));
end;
procedure TFindFiles.SetOnFindFolders(
const Value: TFindFoldersEvent);
begin
SetEvent(TMethod(FOnFindFolders), TMethod(Value));
end;
procedure TFindFiles.SetOnFindFiles(
const Value: TFindFilesEvent);
begin
SetEvent(TMethod(FOnFindFiles), TMethod(Value));
end;
procedure TFindFiles.DoProc(Proc: TThreadMethod; ForceSync: Boolean);
begin
if FAsync
and (FSyncEvents
or ForceSync)
then
FThread.Synchronize(Proc)
else
Proc;
end;
procedure TFindFiles.DoFolderUp;
begin
if Assigned(FOnFolderUp)
then
FOnFolderUp(FFromFolder, FToFolder, FCancel);
end;
procedure TFindFiles.DoEndScan;
begin
if Assigned(FOnEndScan)
then
FOnEndScan(Self, FCancel);
end;
procedure TFindFiles.DoFindFolder;
begin
if Assigned(FOnFindFolder)
then
FOnFindFolder(FFilename, FFindData, FCancel, FSkipDir);
end;
procedure TFindFiles.DoFindFile;
begin
if Assigned(FOnFindFile)
then
FOnFindFile(FFilename, FFindData, FCancel);
end;
procedure TFindFiles.AddDirToDirList;
begin
if Assigned(FOnFindFolders)
then
begin
FFolders.Add(FFilename);
if FFolders.Count >= FMaxEventListSize
then
begin
DoProc(DoFindFolders, True);
FFolders.Clear;
end;
end;
end;
procedure TFindFiles.AddFileToFileList;
begin
if Assigned(FOnFindFiles)
then
begin
FFiles.Add(FFilename);
if FFiles.Count >= FMaxEventListSize
then
begin
DoProc(DoFindFiles, True);
FFiles.Clear;
end;
end;
end;
procedure TFindFiles.DoFindFolders;
begin
if Assigned(FOnFindFolders)
then
FOnFindFolders(FFolders, FCancel);
end;
procedure TFindFiles.DoFindFiles;
begin
if Assigned(FOnFindFiles)
then
FOnFindFiles(FFiles, FCancel);
end;
procedure TFindFiles.SetMaxEventListSize(
const Value: Integer);
begin
if (Value > 0)
and (Value <= MaxListSize)
then
InterlockedExchange(FMaxEventListSize, Value)
else
InterlockedExchange(FMaxEventListSize, MaxListSize);
end;
procedure TFindFiles.SetEvent(
var Event: TMethod;
const Value: TMethod);
begin
if TryLock
then
begin
try
Event := Value;
finally
UnLock;
end;
end else
raise Exception.Create(
'
TFindFiles: Events können nicht während der Suche zugewiesen werden');
end;
function TFindFiles.TryLock: Boolean;
begin
Result := TryEnterCriticalSection(FLock);
end;
procedure TFindFiles.Abort;
begin
FCancel := True;
end;
procedure TFindFiles.SetMask(
const Value:
string);
begin
if TryLock
then
begin
try
FMask := Value;
finally
UnLock;
end;
end else
raise Exception.Create(
'
TFindFiles: Maske kann nicht während der Suche verändert werden');
end;
{ TFindFilesThread }
constructor TFindFilesThread.Create(Parent: TFindFiles);
begin
inherited Create(True);
FParent := Parent;
Resume;
end;
procedure TFindFilesThread.Execute;
begin
FParent.Lock;
try
FParent.Search(FParent.FRootFolder);
if FParent.FFolders.Count > 0
then
Synchronize(FParent.DoFindFolders);
if FParent.FFiles.Count > 0
then
Synchronize(FParent.DoFindFiles);
FParent.FDuration := GetTickCount - FParent.FTicks;
finally
Synchronize(FParent.DoEndScan);
FParent.Unlock;
end;
end;
end.