(*-----------------------------------
ファイル名列挙関数

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の処理を変更
01/11/10    メソッドを簡略化List系とSearch系を一まとめにした
            List時に指定するDirectoryやDestStringsをプロパティにした
2002/11/06  サブフォルダ検索に階層数限定処理をいれた
2005/02/05  サブフォルダ検索のflNormalがバグっていたので
            修正した。
2005/11/09  ファイル情報にDirectoryかFileかの情報を含めた。
            DirectoryExistsを使った所をCheckFileOrFolderに変更して
            動作速度を改善したつもり
2005/11/23
・ファイル更新時間の取得が変だったので
  正しく動作するように変更(SRec.Time→FileTimeToDateTime(SRec.FindData.ftLastWriteTime);
//-----------------------------------*)

(*-----------------------------------
使い方

・Formに配置します
  動的に生成してParentを設定しなくてもOKです。

・プロパティを設定します

  　Directoryプロパティ
      検索したいフォルダ名を指定します
      設定必須

  　FileListTypeプロパティ
      flNormal: 普通のファイル名を列挙(フォルダ名は列挙されません)
      flFolder: フォルダ名だけ列挙(ファイル名は列挙されません)
      flAll:    ファイル名とフォルダ名両方列挙されます
      設定必須

  　DestStringsプロパティ
      列挙された文字列を出力するTStringsを指定します
      指定しなくてもOKです
      列挙した内容は指定されたTStringsにAddされるだけで
      初期化などのClearはされません。

・イベントを設定します
    OnFileFind(FileInfo: TFileInformation; var FileFindAct: TFileFindAct);
      FileInfoに見つかったファイルの情報を格納しています
        TFileInformation = record
          FullPathName: TFileName;
          Time: Integer;
          Size: Integer;
        end;

      FileFindActにイベント内で値を設定する事で
      検索動作を止めたり継続させたりする事ができます
　　    TFileFindAct = (faContinue, faStop);

・ファイル列挙メソッドを呼び出します

    Listメソッド
      1フォルダの中身だけを列挙します

    SubFolderList
      サブフォルダの中身を列挙します
      ReflexiveCount引数でフォルダ階層の
      数を指定できます。1なら1階層だけを検索します。
      デフォルトの0なら階層制限なし。
//-----------------------------------*)

unit FileList;

interface

uses
  Windows, SysUtils, Classes;

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

  TFileOrFolder = (fofFile, fofFolder);

  TFileFolderInformation = record
    FullPathName: TFileName;
    DateTime: TDateTime;
    Size: Integer;
    FileOrFolder: TFileOrFolder;
  end;

  TFileFindAct = (faContinue, faStop);

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

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

    FEmergencyStopFlag: Boolean;
    {↑検索を停止させるフラグ}
    FStringsForSubFolderSearch: TStrings;
    {↑SubFolder検索時に使うTStringsのポインタ}

    FReflexiveMaxCount: Integer;

    FFileListType: TListFile;

    FOnFileFind: TFileFindEvent;
    FDirectory: String;
    FDestStrings: TStrings;
    procedure FileFind(Information: TFileFolderInformation; var FileFindAct: TFileFindAct);
    {↑イベントメソッド}

    procedure OneFolderSearchEngine(SearchDir: String;
     ListingFileType: TListFile; DestStrings: TStrings);
    {↑１ディレクトリ検索エンジン}

    procedure SubFolderSearchEngine(SearchDir: String;
     ListingFileType: TListFile; ReflexiveCount: Integer);
    {↑サブディレクトリを含む検索エンジン}

    procedure SetDirectory(const Value: String);
    procedure SetDestStrings(const Value: TStrings);
    procedure SetFileListType(const Value: TListFile);
    function FoundFile(SearchDir: String; SRec: TSearchRec;
      DestStrings: TStrings): TFileFindAct;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    {↓１フォルダ内でのファイルの列挙/検索}
    function List: Boolean;

    {↓サブフォルダ含めたファイルの列挙/検索}
    function SubFolderList(ReflexiveCount: Integer = 0): Boolean;

    property NowListing: Boolean read FNowListing default false;
    {↑検索中を示すプロパティ
       二重検索(メソッドの二重呼び出し)などの禁止に用いる}

    property DestStrings: TStrings read FDestStrings write SetDestStrings default nil;
    {↑終端に'\'があってもなくてもOK}
  published
    property FileListType: TListFile read FFileListType write SetFileListType default flNormal;
    {↑リストするファイルのタイプを指定}
    property Directory: String read FDirectory write SetDirectory;
    property OnFileFind: TFileFindEvent read FOnFileFind write FOnFileFind;
    {↑FileSearchメソッドによって発生するFileFindイベント}
  end;

  EFileListError = class(Exception);

procedure Register;

implementation

uses SysConst;

{ TFileList }

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

    // TFileTime型をTDateTime型に変換する
    function FileTimeToDateTime(FileTime: TFileTime):TDateTime;
    var
      LocalFileTime: TFileTime;
      SystemTime:   TSystemTime;
    begin
      result := 0;
      if (FileTime.dwLowDateTime = 0) and (FileTime.dwHighDateTime = 0) then
        Exit;
      FileTimeToLocalFileTime(FileTime,LocalFileTime);  {ローカル日時に変換}
      FileTimeToSystemTime(LocalFileTime,SystemTime);   {システム日時に変換}
      Result := SystemTimeToDateTime(SystemTime);       {TDateTime型に変換}
    end;



constructor TFileList.Create(AOwner: TComponent);
begin
  inherited;
  FNowListing := false;
  FEmergencyStopFlag := false;
  FFileListType := flNormal;
  FDirectory := '';
  FDestStrings := nil;
end;

destructor TFileList.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階層のみのフォルダ検索エンジン
備考:
履歴:       2004/09/19
              改めてリファクタリング中
//------------------------------}

function CheckFileOrFolder(SRec: TSearchRec): TFileOrFolder;
begin
  if (SRec.Attr or faDirectory <> Max(SRec.Attr, faDirectory)) then
  begin
    Result := fofFile;
  end else
  begin
    Result := fofFolder;
  end;
end;

{↓イベントを発生させるかorファイル名を列挙する}
function TFileList.FoundFile(SearchDir: String; SRec: TSearchRec;
 DestStrings: TStrings): TFileFindAct;
var
  FileInfo1: TFileFolderInformation;
begin
  Result := faContinue;

  if Assigned(DestStrings) then
    DestStrings.Add(SearchDir + SRec.Name);

  with FileInfo1 do
  begin
    FullPathName := SearchDir + SRec.Name;
    Size := SRec.Size;
//    DateTime := SRec.Time;
    DateTime := FileTimeToDateTime(SRec.FindData.ftLastWriteTime);   {更新日時}

    FileOrFolder := CheckFileOrFolder(SRec);
  end;
  FileFind(FileInfo1, Result);  {←イベント発生}
  {↑このイベントでResultにfaContinue/faStopが選択される}
end;


//1ディレクトリ検索エンジン
{戻り値は検索したファイル個数}
procedure TFileList.OneFolderSearchEngine(SearchDir: String;
  ListingFileType: TListFile;
  DestStrings: TStrings);
var
  SearchRec1: TSearchRec;
  Attr1: Integer;
begin
  if (FEmergencyStopFlag)
    or (not DirectoryExists(SearchDir)) then exit;

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

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

  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 CheckFileOrFolder(SearchRec1) = fofFile then {※}
          Continue;  {←faDirectoryが含まれないのならスキップ}

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

    until not ( FindNext(SearchRec1)=0 );
  finally
    SysUtils.FindClose( SearchRec1 );
  end;
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
に置き換えることが可能。
どれがスピードが速いのかは知りません。
}
//------------------------------


{-------------------------------
//1フォルダのファイルリスト
機能:
引数説明:   Directory: リストするフォルダ
            DestString:
                リスト結果をいれるTStrings
                Addしていくので
                ファイルリストを入れる場合
                事前にClearが必要
                nilも設定可能
戻り値:     True: 正しく終了 False: 強制停止
備考:
履歴:       2001/11/10
//------------------------------}
function TFileList.List: Boolean;
begin
  Result := False;
  if FNowListing then
    raise EFileListError.Create('ファイル検索中です');

  FNowListing := True;
  try
    FEmergencyStopFlag := False;
    OneFolderSearchEngine(FDirectory, FFileListType, FDestStrings);

  finally
    Result := (FEmergencyStopFlag = False);
    FEmergencyStopFlag := False;
    FNowListing := False;
  end;
end;
//------------------------------


//-------------------------------
//サブディレクトリを含む検索エンジン
procedure TFileList.SubFolderSearchEngine(SearchDir: String;
  ListingFileType: TListFile; ReflexiveCount: Integer);
var
  SearchRec1: TSearchRec;
  Attr1: Integer;
begin
  if (FEmergencyStopFlag)
    or (not DirectoryExists(SearchDir)) then exit;

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

  Attr1 := faAnyFile;
(*//flNormalはサブフォルダ検索として不適当でバグっているので修正

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

  2005/07/10
    さらにバグっていたので追記した
        flAll: begin
            {↓イベント発生}
            if FoundFile(SearchDir, SearchRec1, DestStrings) = faStop then
            begin
              FEmergencyStopFlag := true;
              Break; {←イベントからの戻り値で検索を停止する事が可能。}
            end;
        end;

*)

  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;

      case ListingFileType of
        flNormal: begin
          if CheckFileOrFolder(SearchRec1) = fofFile then
            {↓イベント発生}
            if FoundFile(SearchDir, SearchRec1, DestStrings) = faStop then
            begin
              FEmergencyStopFlag := true;
              Break; {←イベントからの戻り値で検索を停止する事が可能。}
            end;
        end;

        flFolder: begin
          if CheckFileOrFolder(SearchRec1) = fofFolder then
            {↓イベント発生}
            if FoundFile(SearchDir, SearchRec1, DestStrings) = faStop then
            begin
              FEmergencyStopFlag := true;
              Break; {←イベントからの戻り値で検索を停止する事が可能。}
            end;
        end;

        flAll: begin
            {↓イベント発生}
            if FoundFile(SearchDir, SearchRec1, DestStrings) = faStop then
            begin
              FEmergencyStopFlag := true;
              Break; {←イベントからの戻り値で検索を停止する事が可能。}
            end;
        end;
      else
        Assert(False, 'エラー');
      end;

      if CheckFileOrFolder(SearchRec1) = fofFolder then
      begin
        if (FReflexiveMaxCount = 0) or
          (ReflexiveCount < FReflexiveMaxCount) then
        begin
          {↓ReflexiveCountをインクリメントして再起呼び出し}
          SubFolderSearchEngine(SearchDir+SearchRec1.Name,
            ListingFileType, ReflexiveCount+1);
        end;
      end;

    until not ( FindNext(SearchRec1)=0 );
  finally
    FindClose( SearchRec1 );
  end;
end;

//var
//  i: Integer;
//  SubFolderStrList: TStringList;
//  FindEventBuff: TFileFindEvent;
//begin
//  if (FEmergencyStopFlag)
//    or (not DirectoryExists(SearchDir)) then exit;

//  OneFolderSearchEngine(SearchDir, ListingFileType,
//                        FStringsForSubFolderSearch);
//
//  {↓0なら階層指定なし
//     規定された再起回数以下かどうか判断している}
//  if (FReflexiveMaxCount = 0)
//    or (ReflexiveCount < FReflexiveMaxCount) then
//  begin
//    SubFolderStrList := TStringList.Create; try
//    SubFolderStrList.Clear;
//    {↓イベントのバッファリング}
//    FindEventBuff := Self.FOnFileFind;
//    Self.FOnFileFind := nil;
//    OneFolderSearchEngine( SearchDir, flFolder, SubFolderStrList);
//    Self.FOnFileFind := FindEventBuff;
//
//    {↓フォルダが1つ以上存在するなら
//       再帰で検索}
//    for i := 0 to SubFolderStrList.Count - 1 do
//    begin
//      SubFolderSearchEngine(SubFolderStrList[i], ListingFileType, ReflexiveCount+1);
//    end;
//
//    finally SubFolderStrList.Free; end;
//  end;
//end;

{-------------------------------
//サブフォルダのファイルリスト
機能:
引数説明:   Directory: リストする元フォルダ
             リスト結果をいれるTStrings
             検索していくたびにAddしていくので
             最初ににClearが必要
             nilも設定可能
            ReflexiveCount: 再帰呼び出し限定回数
             サブフォルダを指定階層だけしか検索しない時に指定する
             1を指定すると1階層だけ検索する事になり
             サブフォルダを指定しないファイルのリストと
             同じ処理になる。
             0なら階層制限なし。

戻り値:     True: 正しく終了 False: 強制停止
備考:
履歴:       2001/11/10
            2002/11/06
              再帰呼び出し回数の限定処理を入れる
//------------------------------}
function TFileList.SubFolderList(ReflexiveCount: Integer = 0): Boolean;
begin
  Result := False;
  if FNowListing then
    raise EFileListError.Create('ファイル検索中です');

  if ReflexiveCount < 0 then ReflexiveCount := 0;

  FNowListing := True;
  try
    FEmergencyStopFlag := False;
    FStringsForSubFolderSearch := FDestStrings;
    FReflexiveMaxCount := ReflexiveCount;
    SubFolderSearchEngine(FDirectory, FFileListType, 1);
  finally
    Result := (FEmergencyStopFlag = False);
    FEmergencyStopFlag := False;
    FNowListing := False;
  end;
end;
//------------------------------

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

procedure TFileList.SetDirectory(const Value: String);
begin
  if FNowListing then
    raise EFileListError.Create('ファイル検索中です');

  if FDirectory <> Value then
    FDirectory := Value;
end;


procedure TFileList.SetDestStrings(const Value: TStrings);
begin
  if FNowListing then
    raise EFileListError.Create('ファイル検索中です');

  if FDestStrings <> Value then
    FDestStrings := Value;
end;

procedure TFileList.SetFileListType(const Value: TListFile);
begin
  if FNowListing then
    raise EFileListError.Create('ファイル検索中です');

  if FFileListType <> Value then
    FFileListType := Value;
end;

end.