Как получить список файлов и поддиректорий в указанной директории

{$B-}
unit DirScan;

interface

uses
  RegExpr, SysUtils, Classes;

type
  PDirectoryScannerItem = ^TDirectoryScannerItem;
  TDirectoryScannerItem = packed record
    name : string;
    Size : integer;
    LastWriteTime : TDateTime;
  end;

  TOnDirScanFileProceed = procedure (Sender : TObject; const ABaseFolder : string;
    const ASearchRecord : TSearchRec; var ACancel : boolean) of object;
  TOnDirScanStartFolderScanning = procedure (Sender : TObject; const AFolder : string) of object;
  TOnDirScanTimeSlice = procedure (Sender : TObject; var ACancel : boolean) of object;

  TCustomDirectoryScanner = class
    private
      fRegExprMask : string;
      fRecursive : boolean;
      fCount : integer;
      fOnFileProceed : TOnDirScanFileProceed;
      fOnStartFolderScanning : TOnDirScanStartFolderScanning;
      fOnTimeSlice : TOnDirScanTimeSlice;
      fMaskRegExpr : TRegExpr;
      function BuildFileListInt (const AFolder : string) : boolean;
    public
      constructor Create;
      destructor Destroy; override;

      property Recursive : boolean read fRecursive write fRecursive;
      property RegExprMask : string read fRegExprMask write fRegExprMask;
      // regular expresion for file names masks (like '(\.html?|\.xml)' etc)
      function BuildFileList (AFolder : string) : boolean;
      // Build list of all files in folder AFolder.
      // If ASubFolder = true then recursivly scans subfolders.
      // Returns false if there was file error and user
      // decided to terminate process.

      property Count : integer read fCount;
      // matched in last BuildFileList files count

      // Events
      property OnFileProceed : TOnDirScanFileProceed read fOnFileProceed write fOnFileProceed;
      // for each file matched
      property OnStartFolderScanning : TOnDirScanStartFolderScanning read fOnStartFolderScanning 
        write fOnStartFolderScanning;
      // before scanning each directory (starting with root)
      property OnTimeSlice : TOnDirScanTimeSlice read fOnTimeSlice write fOnTimeSlice;
      // for progress bur an so on (called in each internal iteration)
  end;

  TDirectoryScanner = class (TCustomDirectoryScanner)
   // simple descendant - after BuildFileList call make list of files
   // (You can access list thru Item property)
   private
     fList : TList;
     function GetItem (AIdx : integer) : PDirectoryScannerItem;
     procedure KillItem (AIdx : integer);
     procedure FileProceeding (Sender : TObject; const ABaseFolder : string;
       const ASearchRecord : TSearchRec; var ACancel : boolean);
     procedure TimeSlice (Sender : TObject; var ACancel : boolean);
   public
     constructor Create;
     destructor Destroy; override;

     property Item [AIdx : integer] : PDirectoryScannerItem read GetItem;
  end;



implementation

uses
  Windows, Controls, TFUS;

constructor TCustomDirectoryScanner.Create;
begin
  inherited;
  fRecursive := true;
  fOnFileProceed := nil;
  fOnStartFolderScanning := nil;
  fOnTimeSlice := nil;
  fMaskRegExpr := nil;
  fRegExprMask := '';
end; { of constructor TDirectoryScanner.Create}

destructor TCustomDirectoryScanner.Destroy;
begin
  fMaskRegExpr.Free;
  inherited;
end; { of destructor TCustomDirectoryScanner.Destroy}

function TCustomDirectoryScanner.BuildFileList (AFolder : string) : boolean;
begin
  if (length (AFolder) > 0) and (AFolder [length (AFolder)] = '\')
   then AFolder := copy (AFolder, 1, length (AFolder) - 1);

  fMaskRegExpr := TRegExpr.Create;
  fMaskRegExpr.Expression := RegExprMask;

  fCount := 0;
  Result := BuildFileListInt (AFolder);
end; { function BuildFileList}

function TCustomDirectoryScanner.BuildFileListInt (const AFolder : string) : boolean;
var
  sr : SysUtils.TSearchRec;
  Canceled : boolean;
begin
  Result := true;
  if Assigned (OnStartFolderScanning)
   then OnStartFolderScanning (Self, AFolder + '\');

  if SysUtils.FindFirst (AFolder + '\' + '*.*', faAnyFile, sr) = 0 then try
       repeat
        try
           if (sr.Attr and SysUtils.faDirectory) = SysUtils.faDirectory then begin
             if Recursive and (sr.name <> '.') and (sr.name <> '..')
              then Result := BuildFileListInt (AFolder + '\' + sr.name);
             end
            else begin
               if fMaskRegExpr.Exec (sr.name) then begin
                Canceled := false;
                if Assigned (OnFileProceed)
                 then OnFileProceed (Self, AFolder, sr, Canceled);
                if Canceled
                 then Result := false;
                inc (fCount);
               end;
             end;
          except on E:Exception do begin
            case MsgBox ('Replacing error',
                  'Can''t replace file contetn due to error:'#$d#$a#$d#$a
                  + E.message + #$d#$a#$d#$a + 'Continue processing ?',
                  mb_YesNo or mb_IconQuestion) of
              mrYes : Result := false;
              >else ; // must be No
             end;
           end;
         end;
        Canceled := false;
        if Assigned (OnTimeSlice)
         then OnTimeSlice (Self, Canceled);
        if Canceled
         then Result := false;
       until not Result or (SysUtils.FindNext (sr) <> 0);
      finally SysUtils.FindClose (sr);
     end;
  if not Result
   then EXIT;
end; { function BuildFileListInt}

constructor TDirectoryScanner.Create;
begin
  inherited;
  fList := TList.Create;
  OnFileProceed := FileProceeding;
  fOnTimeSlice := TimeSlice;
end; { of constructor TDirectoryScanner.Create}

destructor TDirectoryScanner.Destroy;
var
  i : integer;
begin
  for i := fList.Count - 1 downto 0 do
   KillItem (i);
  fList.Free;
  inherited;
end; { of destructor TDirectoryScanner.Destroy}

procedure TDirectoryScanner.KillItem (AIdx : integer);
var
  p : PDirectoryScannerItem;
begin
  p := PDirectoryScannerItem (fList.Items [AIdx]);
  Dispose (p);
  fList.Delete (AIdx);
end; { of procedure TDirectoryScanner.KillItem}

function TDirectoryScanner.GetItem (AIdx : integer) : PDirectoryScannerItem;
begin
  Result := PDirectoryScannerItem (fList.Items [AIdx]);
end; { of function TDirectoryScanner.GetItem}

procedure TDirectoryScanner.FileProceeding (Sender : TObject; const ABaseFolder : string;
const ASearchRecord : TSearchRec; var ACancel : boolean);
var
  p : PDirectoryScannerItem;
begin
  p := New (PDirectoryScannerItem);
  p.name := ABaseFolder + '\' + ASearchRecord.name;
  fList.Add (p);
end; { of procedure TDirectoryScanner.FileProceeding}

procedure TDirectoryScanner.TimeSlice (Sender : TObject; var ACancel : boolean);
begin
  if Count mod 100 = 0
   then Sleep (0);
end; { of procedure TDirectoryScanner.TimeSlice}

end.