////////////////////////////////////////////////////////////
//ファイル名列挙関数
//99/12/24
//99/12/26
//99/12/27  2重同時検索の防止など、実用に耐えるものになった。
//99/12/29  LastDelimiterDeleteを追加
//00/04/25  LastDelimiterはD5ではExcludeTrailingBackslashに置き換え可能だよ
//00/06/15  全面的にアルゴリズム変えて
//          OneFolderEngine と SubFolderEngine を搭載
//          サブディレクトリでもファイルリスティングが可能になった
//00/08/09  Register指令を付けてみました
//00/12/25  OnFileFindイベントをpublishedにしました
//01/07/23  FindFirst..FindCloseの処理を変更
{ --▽---------------------------▼--
  if FindFirst( SearchDir + '*.*', Attr1, SearchRec1) <> 0 then exit;
  repeat
    …省略…
  until not ( FindNext(SearchRec1)=0 );
  FindClose( SearchRec1 );
  Result := FileCount;

↓変更

  if FindFirst( SearchDir + '*.*', Attr1, SearchRec1) = 0 then
  try
    repeat
      …省略…
    until not ( FindNext(SearchRec1)=0 );
  finally
    FindClose( SearchRec1 );
  end;
  Result := FileCount;
//--▲---------------------------△-- }
////////////////////////////////////////////////////////////
unit FileList;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  FileCtrl;

type
  TListingFileType = (flNormal, flFolder, flAll);
  TMethodMode = (mmListing, mmSearch);

  TFileInformation = record
    FullPathName: TFileName;
    Time: Integer;
    Size: Integer;
  end;

  TFileFindAct = (faContinue, faStop);

  TFileFindEvent
    = procedure(FileInfo: TFileInformation; var FileFindAct: TFileFindAct)of Object;
  {↑Fileが見つかったら呼び出されるイベントの定義}

//コンポーネント本体
  TFileListing = class(TComponent)
  private
    FOnFileFind: TFileFindEvent;
    FFileListingNow: Boolean;
    {↑二重検索不可につかうフラグ}

    FEmergencyEngineStopFlag: Boolean; {←絶対検索をストップさせるフラグ}
    FStringsForSubFolderSearch: TStrings; {←SubFolder検索時に使うTStringsのポインタ}
    FFileCountForSubFolderSearch: Integer; {←SubFolder検索時に使う列挙したファイルの数}

    procedure FileFind(Information: TFileInformation; var FileFindAct: TFileFindAct);
    {↑イベントメソッド}

    function OneFolderSearchEngine(SearchDir: String; MethodMode: TMethodMode;
     ListingFileType: TListingFileType; DestStrings: TStrings): Integer;
    {↑１ディレクトリ検索エンジン}

    procedure SubFolderSearchEngine(SearchDir: String;
     MethodMode: TMethodMode; ListingFileType: TListingFileType);
    {↑サブディレクトリを含む検索エンジン}
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    {↓１フォルダ内でのファイルの列挙/検索}
    function FileListing(SearchDir: String; DestStrings: TStrings;
     ListingFileType: TListingFileType): Integer;
    procedure FileSearch(SearchDir: String;
     ListingFileType: TListingFileType);

    {↓サブフォルダ含めたファイルの列挙/検索}
    function SubFolderFileListing(SearchStartDir: String; DestStrings: TStrings;
     ListingFileType: TListingFileType): Integer;
    procedure SubFolderFileSearch(SearchStartDir: String;
     ListingFileType: TListingFileType);

    property FileListingNow: Boolean read FFileListingNow default false;
    {↑二重検索(メソッドの二重呼び出し)が禁止される
     このプロパがTrueなら検索中}
  published
    property OnFileFind: TFileFindEvent read FOnFileFind write FOnFileFind;
    {↑FileSearchメソッドによって発生するFileFindイベント}
  end;

procedure Register;

implementation

{ TFileListing }

procedure Register;
begin
  RegisterComponents('Samples', [TFileListing]);
end;

constructor TFileListing.Create(AOwner: TComponent);
begin
  inherited;
  FFileListingNow := false;
  FEmergencyEngineStopFlag := false;
end;

destructor TFileListing.Destroy;
begin
  inherited;
end;

//-------------------------------
//最後の\記号を取り除く処理
{↓D5以降ではExcludeTrailingBackslashで代用可能}
function LastDelimiterDelete(FolderName: String): String;
begin
  Result := FolderName;
  if Length(FolderName) = LastDelimiter('\', FolderName) then
  begin        {↑最後の区切り文字\が文字列と同じ長さのとこにある場合}
    Result := Copy(FolderName, 1, Length(FolderName)-1);
  end;         {↑左から一つ削除}
end;

//-------------------------------
//Mathユニットから取り出した
function Max(A,B: Integer): Integer;
begin
  if A > B then
    Result := A
  else
    Result := B;
end;

//-------------------------------
//1ディレクトリ検索エンジン
{戻り値は検索したファイル個数}
function TFileListing.OneFolderSearchEngine(SearchDir: String;
  MethodMode: TMethodMode; ListingFileType: TListingFileType;
  DestStrings: TStrings): Integer;

    {↓イベントを発生させるかorファイル名を列挙する}
    function FoundFile(SRec: TSearchRec): TFileFindAct;
    var
      FileInfo1: TFileInformation;
    begin
      Result := faContinue;
      case MethodMode of
        mmListing:
        begin
          if DestStrings <> nil then
            DestStrings.Add(SearchDir + SRec.Name);
        end;
        mmSearch:
        begin
          FileInfo1.FullPathName := SearchDir + SRec.Name;
          FileInfo1.Size := SRec.Size;
          FileInfo1.Time := SRec.Time;
          FileFind(FileInfo1, Result);  {←イベント発生}
          {↑このイベントでfaContinue/faStopが選択される}
        end;
      end;
    end;

var
  SearchRec1: TSearchRec;
  Attr1, FileCount: Integer;
begin
  Result := -1;
  if (FEmergencyEngineStopFlag)
    or (not DirectoryExists(SearchDir)) then exit;
  Result := 0;

  SearchDir := LastDelimiterDelete(SearchDir) + '\';
//  SearchDir := IncludeTrailingBackslash( SearchDir );
  {↑D5以降でのやり方}

  case ListingFileType of
   flNormal:
    begin
      Attr1 := faAnyFile - faDirectory;
      {※101111 ← 111111 - 010000}
    end;
   flFolder:
    begin
      Attr1 := faAnyFile;
      {※010000}
      {なぜかfaDirectoryを指定するとFindFirstのループが正しく動作しない!!
       if SearchRec1.Attr or faDirectory...の行で改めて判断している}
    end;
   flAll:
    begin
      Attr1 := faAnyFile;
      {※111111}
    end;
    else
      raise Exception.Create('変');
  end;

  FileCount := 0;
  if FindFirst( SearchDir + '*.*', Attr1, SearchRec1) = 0 then
  try
    repeat
      if (SearchRec1.Name = '') then
      begin
        raise Exception.Create('SearchRecエラー');
        Exit;
      end;

      if (SearchRec1.Name = '.') or (SearchRec1.Name = '..') then
        Continue;

      if ListingFileType = flFolder then
        if SearchRec1.Attr or faDirectory <> Max(SearchRec1.Attr, faDirectory) then {※}
          Continue;  {←faDirectoryが含まれないのならスキップ}

      Inc(FileCount);
      if FoundFile(SearchRec1) = faStop then
      begin
        FEmergencyEngineStopFlag := true;
        Break; {←イベントからの戻り値で検索を停止する事が可能。}
      end;

    until not ( FindNext(SearchRec1)=0 );
  finally
    FindClose( SearchRec1 );
  end;
  Result := FileCount;
end;
{※論理演算の説明
unit SysUtils;によると
              // 16進数    10進数   2進数
  faReadOnly  = $00000001; // 1;    000001
  faHidden    = $00000002; // 2;    000010
  faSysFile   = $00000004; // 4;    000100
  faVolumeID  = $00000008; // 8;    001000
  faDirectory = $00000010; // 16;   010000
  faArchive   = $00000020; // 32;   100000
  faAnyFile   = $0000003F; // 63;   111111
                           // 48;   110000
このように定義されています。
そこで、ビット演算をして
48に16が含まれるのかどうかを判断したい時は

48と16を論理和した値と、
48と16の大きい方の値を比較して、
同じ値なら含まれるという事になります。

今回の場合はSearchRec1.Attrが48等でfaDirectoryが16になります。
────────────────────
余談だけど
 if SearchRec1.Attr or faDirectory <> Max(SearchRec1.Attr, faDirectory) then
この行は
 if not (SearchRec1.Attr and faDirectory>0) then
や
 if not DirectoryExists(SearchRec1.Name) then
に置き換えることが可能。
どれがスピードが速いのかは知りません。
}

//-------------------------------
//ファイルサーチ
procedure TFileListing.FileSearch(SearchDir: String;
  ListingFileType: TListingFileType);
begin
  if FFileListingNow then exit;

  FFileListingNow := true;
  OneFolderSearchEngine(SearchDir, mmSearch, ListingFileType, nil);
  FEmergencyEngineStopFlag := false;
  FFileListingNow := false;
end;

//-------------------------------
//ファイルリスト
function TFileListing.FileListing(SearchDir: String; DestStrings: TStrings;
  ListingFileType: TListingFileType): Integer;
begin
  Result := -1;
  if FFileListingNow then exit;

  FFileListingNow := true;
  Result :=
   OneFolderSearchEngine(SearchDir, mmListing, ListingFileType, DestStrings);
  FEmergencyEngineStopFlag := false;
  FFileListingNow := false;
end;
              
//-------------------------------
//サブディレクトリを含む検索エンジン
procedure TFileListing.SubFolderSearchEngine(SearchDir: String;
  MethodMode: TMethodMode; ListingFileType: TListingFileType);
var
  i, IncCount: Integer;
  SubFolderStrList: TStringList;
begin
  if (FEmergencyEngineStopFlag)
    or (not DirectoryExists(SearchDir)) then exit;

  IncCount := OneFolderSearchEngine(SearchDir, MethodMode, ListingFileType,
                                    FStringsForSubFolderSearch);
  if IncCount > 0 then
  Inc(FFileCountForSubFolderSearch, IncCount);

  SubFolderStrList := TStringList.Create;
  try
    SubFolderStrList.Clear;
    if OneFolderSearchEngine( SearchDir, mmListing, flFolder, SubFolderStrList) > 0 then
    begin
      for i := 0 to SubFolderStrList.Count - 1 do
      begin
        SubFolderSearchEngine(SubFolderStrList[i], MethodMode, ListingFileType);
      end;

    end;

  finally
    SubFolderStrList.Free;
  end;
end;

//-------------------------------
//サブフォルダサーチ
procedure TFileListing.SubFolderFileSearch(SearchStartDir: String;
  ListingFileType: TListingFileType);
begin
  if FFileListingNow then exit;

  FFileListingNow := true;
  FStringsForSubFolderSearch := nil;

  SubFolderSearchEngine(SearchStartDir, mmSearch, ListingFileType);

  FEmergencyEngineStopFlag := false;
  FFileListingNow := false;
end;

//-------------------------------
//サブフォルダリスト
function TFileListing.SubFolderFileListing(SearchStartDir: String;
  DestStrings: TStrings; ListingFileType: TListingFileType): Integer;
begin
  Result := -1;
  if FFileListingNow then exit;

  FFileListingNow := true;
  FFileCountForSubFolderSearch := 0;
  FStringsForSubFolderSearch := DestStrings;

  SubFolderSearchEngine(SearchStartDir, mmListing, ListingFileType);

  Result := FFileCountForSubFolderSearch;
  FEmergencyEngineStopFlag := false;
  FFileListingNow := false;
end;

//-------------------------------
//イベント
procedure TFileListing.FileFind(Information: TFileInformation;
 var FileFindAct: TFileFindAct);
begin
  if Assigned(FOnFileFind) then FOnFileFind(Information, FileFindAct);
end;

end.