(*----------------------------------------
ファイルとフォルダを列挙するユニット
FileListコンポーネントとは別に、匿名メソッドを使えるような
.NET TDirectoryと似た実装で作成してみた。
2011/11/15(火)
・作成
----------------------------------------
使い方

ファイルとフォルダを列挙する関数
IOUtils の TDirectory クラス
GetFileSystemEntries / GetFiles / GetDirectories とほぼ互換

次のように実装すると、ファイルパスを列挙することができる

procedure TForm1.Button1Click(Sender: TObject);
var
  Files: TStringDynArray;
  FolderPath: String;
  I: Integer;
begin
  FolderPath := ExtractFileDir(Application.ExeName);
  Files := GetFileSystemEntries(FolderPath, soAllDirectories,
    function(const Path: string; const SearchRec: TSearchRec): Boolean
    begin
      Result := True;
      if (SearchRec.Attr and faDirectory) > 0 then
      begin
        //ディレクトリを列挙
        Memo1.Lines.Add('Dir:' + Path + PathDelim + SearchRec.Name);
      end else
      begin
        //ファイルを列挙
        Memo1.Lines.Add('File:' + Path + PathDelim + SearchRec.Name);
      end;
    end );
end;

GetFileSystemEntries:	ファイルディレクトリ両方
GetFiles:				ファイル
GetDirectories:			ディレクトリ
各関数の戻り値は文字列配列。
無名関数でTrueを返すと戻り値に値が追加される

リストアップする方法は
 
  type TGetFileFoldersArgs.SearchOption = 
       (soTopDirectoryOnly, soAllDirectories);

で定義されている。
最上位のディレクトリのみか、
再帰的に全部のディレクトリ対象にしたリストアップ方法を選ぶことができる。

途中でリストアップをキャンセルする場合
次のように実装する

procedure TForm1.Button2Click(Sender: TObject);
var
  Files: TStringDynArray;
  FolderPath: String;
  I: Integer;
begin
  FolderPath := ExtractFileDir(Application.ExeName);
  Files := GetFileFolders(FolderPath, ioAny, soAllDirectories,
    procedure(const Path: string; const SearchRec: TSearchRec;
     var ItemAdd: Boolean; var ListupStop: Boolean)
    begin
      if (SearchRec.Attr and faDirectory) > 0 then
      begin
        //ディレクトリを列挙
        Memo1.Lines.Add('Dir:' + Path + PathDelim + SearchRec.Name);
      end else
      begin
        //ファイルを列挙
        Memo1.Lines.Add('File:' + Path + PathDelim + SearchRec.Name);
      end;
      if SearchRec.Name = 'Unit1.dcu' then
      begin
        ItemAdd := False;
        ListupStop := True;
      end;
    end );
end;

ItemAdd: 	デフォルト:True		項目追加するかどうかを制御
ListupStop:	デフォルト:False	Trueならリストアップをキャンセルする
//----------------------------------------*)
unit GetFileFoldersUnit;

interface

uses
  SysUtils,
  Types,
end_uses;

type
  TGetFileFoldersArgs = class
    public
      type ItemOption = (ioAny, ioFile, ioDirectory);
      type SearchOption = (soTopDirectoryOnly, soAllDirectories);

      type FilterProcedure = reference to procedure(const Path: string;
        const SearchRec: TSearchRec;
        var ItemAdd: Boolean;
        var ListupStop: Boolean);

      type RecursiveCallProcedure = reference to procedure(const Path: string;
        var ListupSkip: Boolean;
        var ListupStop: Boolean);

      type FilterFunction = reference to function(const Path: string;
        const SearchRec: TSearchRec): Boolean;
  end;

function GetFilesDirectories(Path: String; ItemOption: TGetFileFoldersArgs.ItemOption;
 SearchOption: TGetFileFoldersArgs.SearchOption = soTopDirectoryOnly;
 FilterProcedure: TGetFileFoldersArgs.FilterProcedure = nil;
 RecursiveCallProcedure: TGetFileFoldersArgs.RecursiveCallProcedure = nil): TStringDynArray;

function GetFileSystemEntries(Path: String;
 SearchOption: TGetFileFoldersArgs.SearchOption = soTopDirectoryOnly;
 FilterFunction: TGetFileFoldersArgs.FilterFunction = nil): TStringDynArray;
function GetFiles(Path: string;
 SearchOption: TGetFileFoldersArgs.SearchOption = soTopDirectoryOnly;
 FilterFunction: TGetFileFoldersArgs.FilterFunction = nil): TStringDynArray;
function GetDirectories(Path: string;
 SearchOption: TGetFileFoldersArgs.SearchOption = soTopDirectoryOnly;
 FilterFunction: TGetFileFoldersArgs.FilterFunction = nil): TStringDynArray;

implementation

function GetFilesDirectories(Path: String; ItemOption: TGetFileFoldersArgs.ItemOption;
 SearchOption: TGetFileFoldersArgs.SearchOption = soTopDirectoryOnly;
 FilterProcedure: TGetFileFoldersArgs.FilterProcedure = nil;
 RecursiveCallProcedure: TGetFileFoldersArgs.RecursiveCallProcedure = nil): TStringDynArray;

var
  StopFlag: Boolean;

    function IsDirecotry(sr: TSearchRec): Boolean;
    begin
      Result := (sr.Attr and faDirectory) > 0;
    end;

    procedure GetFileFoldersCore(Path: string);
    var
      SearchRec: TSearchRec;
      ListUpFlag: Boolean;
      ItemAdd: Boolean;
      ListUpStop: Boolean;
      ListUpSkip: Boolean;
    begin
      if StopFlag then Exit;

      Path := ExcludeTrailingPathDelimiter(Path);

      if Assigned(RecursiveCallProcedure) then
      begin
        ListupStop := False;
        ListUpSkip := True;
        RecursiveCallProcedure(Path, ListUpSkip, ListUpStop);
        if ListUpSkip then Exit;
        if ListUpStop then
        begin
          StopFlag := True;
          Exit;
        end;
      end;

      if FindFirst(Path + PathDelim + '*.*', faAnyFile, SearchRec) = 0 then try
      repeat
        if (SearchRec.Name = '.') or (SearchRec.Name = '..') then continue;

        ListUpFlag := False;
        if (ItemOption = ioAny) then
        begin
          ListUpFlag := True;
        end else
        if (ItemOption = ioFile) and (not IsDirecotry(SearchRec)) then
        begin
          ListUpFlag := True;
        end else
        if (ItemOption = ioDirectory) and (IsDirecotry(SearchRec)) then
        begin
          ListUpFlag := True;
        end;

        if ListUpFlag then
        begin
          if Assigned(FilterProcedure) then
          begin
            ItemAdd := True;
            ListUpStop := False;
            FilterProcedure(Path, SearchRec, ItemAdd, ListUpStop);

            if ItemAdd then
            begin
              SetLength(Result, Length(Result) + 1);
              Result[Length(Result)-1] := Path + PathDelim + SearchRec.Name;
            end;

            if ListUpStop then
            begin
              StopFlag := True;
              Break;
            end else
            begin
              StopFlag := False;
            end;
          end else
          begin
            SetLength(Result, Length(Result) + 1);
            Result[Length(Result)-1] := Path + PathDelim + SearchRec.Name;
          end;
        end;

        if IsDirecotry(SearchRec)
        and (SearchOption = soAllDirectories) then
        begin
          GetFileFoldersCore(Path + PathDelim + SearchRec.Name);
          if StopFlag then
          begin
            Break;
          end;
        end;

      until FindNext(SearchRec) <> 0;
      finally FindClose(SearchRec); end;
    end;

begin
  StopFlag := False;
  SetLength(Result, 0);
  GetFileFoldersCore(Path);
end;

function _GetFileFolders(Path: String;
 ItemOption: TGetFileFoldersArgs.ItemOption;
 SearchOption: TGetFileFoldersArgs.SearchOption;
 FilterFunction: TGetFileFoldersArgs.FilterFunction): TStringDynArray;
begin
  if Assigned(FilterFunction) then
  begin
    Result := GetFilesDirectories(Path, ItemOption, SearchOption,
      procedure (const Path: string; const SearchRec: TSearchRec;
       var ItemAdd: Boolean; var ListupStop: Boolean)
      begin
        listupStop := False;
        ItemAdd := FilterFunction(Path, SearchRec);
      end );
  end else
  begin
    Result := GetFilesDirectories(Path, ItemOption, SearchOption);
  end;
end;

function GetFileSystemEntries(Path: String;
 SearchOption: TGetFileFoldersArgs.SearchOption = soTopDirectoryOnly;
 FilterFunction: TGetFileFoldersArgs.FilterFunction = nil): TStringDynArray;
begin
  Result := _GetFileFolders(Path, ioAny, SearchOption, FilterFunction);
end;

function GetFiles(Path: string;
 SearchOption: TGetFileFoldersArgs.SearchOption = soTopDirectoryOnly;
 FilterFunction: TGetFileFoldersArgs.FilterFunction = nil): TStringDynArray;
begin
  Result := _GetFileFolders(Path, ioFile, SearchOption, FilterFunction);
end;

function GetDirectories(Path: string;
 SearchOption: TGetFileFoldersArgs.SearchOption = soTopDirectoryOnly;
 FilterFunction: TGetFileFoldersArgs.FilterFunction = nil): TStringDynArray;
begin
  Result := _GetFileFolders(Path, ioDirectory, SearchOption, FilterFunction);
end;








end.