Rekursive Dateisuche mit Filter und Prozessanzeige

Rekursive Dateisuche mit Filter und Prozessanzeige

Beitragvon Rocktagon » Mo 25. Feb 2013, 11:38

Rekursive Dateisuche mit Filter und Prozessanzeige:

Code: Alles auswählen
type
  TAktDir = procedure(S: String);

uses PatternMatch; // Im Dateianhang - für die Filterfunktion

function GetDirList(Pfad: string; Rekursiv: boolean = true; Filter: string = ''; SAkt: TAktDir = nil): tstringlist;
var
  sa: tsearchrec;
begin
  result := tstringlist.Create;
  if assigned(SAkt) then
    SAkt(Pfad);
  if Pfad[length(Pfad)] <> '\' then
    Pfad := Pfad + '\';
  if findfirst(Pfad + '*.*', faanyfile, sa) = 0 then
    repeat
      if (sa.Name <> '.') and (sa.Name <> '..') then
      begin
        If ((sa.attr and fadirectory) = fadirectory) then
        begin
          if Rekursiv then
            result.AddStrings(GetDirList(Pfad + sa.Name, Rekursiv, Filter, SAkt))
        end
        else if (Filter = '') or (MatchPattern(pchar(sa.Name), pchar(Filter))) then
          result.add(Pfad + sa.Name);
      end;
    Until FindNext(sa) <> 0;
  findclose(sa);
end;


Aufruf:

Code: Alles auswählen
procedure OnChDir(s:String);
begin
Form1.label1.caption:=s;
application.ProcessMessages;
end;


GetDirList('C:\temp', true, '*.*', OnChDir)



Das ganze als Thread (Empfehlung 1 Thread pro Laufwerk - mehrere Pro Laufwerk verlangsamen):

Code: Alles auswählen
type
  TAktDir = procedure(S: String);
  // ***** GET Dir Thread
  TGetDirOnDoneEvent = procedure(Sender: TObject; FileList: tstringlist) of object;

  TGetThreadedDirList = class(TThread)
  private
    FFileList: tstringlist;
    fOnDone: TGetDirOnDoneEvent;

  protected
    procedure Execute; override;
  public
    Directorys: tstringlist;
    Filter: string;
    OnDone: procedure(szString: tstringlist);
    OnChangeDir: TAktDir;
    Rekursiv: boolean;
    procedure ScanDir;
    constructor Create;
    destructor Destroy; override;
    // property OnDone: TGetDirOnDoneEvent read fOnDone write fOnDone;
  end;
  // ***** GET Dir Thread


implementation


procedure TGetThreadedDirList.ScanDir;
var
  x: word;
begin
  if not assigned(OnDone) then
  begin
    showmessage('Keine Rückgabeprozedure angegeben');
    exit;
  end;
  if Directorys.Count = 0 then
  begin
    showmessage('Keine Verzeichnisse zum durchsuchen');
    exit;
  end;
  for x := 0 to Directorys.Count - 1 do
  begin
    FFileList.AddStrings(GetDirList(Directorys[x], Rekursiv, Filter, OnChangeDir));
  end;
  showmessage('fertig');
  OnDone(FFileList);
end;

procedure TGetThreadedDirList.Execute;
begin
  // Wird nur bei   inherited Create(false); ausgeführt
end;

constructor TGetThreadedDirList.Create;
begin
  inherited Create(true); // True = nicht Execute ausführen. Mit Resume starten
  NameThreadForDebugging(AnsiString(ClassName));
  fOnDone := nil; // ??
  OnChangeDir := nil;
  Filter := '';
  Rekursiv := false;
  FFileList := tstringlist.Create;
  Directorys := tstringlist.Create;
  FreeOnTerminate := true;
end;

destructor TGetThreadedDirList.Destroy;
begin
  FFileList.free;
  Directorys.free;
  inherited; // Objekt auflösen
end;


Aufruf:

Code: Alles auswählen
 

procedure OnThreadend(FileList: tstringlist);
begin
 Form1.Memo1.Lines:=FileList;
end;


with TGetThreadedDirList.Create do
 begin
 OnDone:=OnThreadend;
 OnChangeDir:=onchdir;
 rekursiv:=true;
 Directorys.Add('C:\Tmp');
 ScanDir;
 end;
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
Non mihi non tibi sed nobis
nightlight ÄT gmx PUNKT de
Benutzeravatar
Rocktagon
Administrator
 
Beiträge: 142
Registriert: So 28. Okt 2012, 10:15
Wohnort: NRW

Zurück zu Delphi

Wer ist online?

Mitglieder in diesem Forum: NewBot und 0 Gäste

Fatal: Not able to open ./cache/data_global.php