////////////////////////////////////////////////////////////
//ファイル名列挙関数
//99/12/24 5:23
//99/12/26
//99/12/27 2重同時検索の防止など、実用に耐えるものになった。
//99/12/29 LastDelimiterDeleteを追加
////////////////////////////////////////////////////////////

unit FileList;

interface

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

type
  TListingFileType = (flNormal, flFolder);
  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; {2重検索不可のように検索の時につかうフラグ}

    function FileListingBase(FileType: TListingFileType; Method: TMethodMode;
     SearchDir, WildCard: String;
     Attr: Integer; ResultList: TStrings): Boolean;

    procedure FileFind(Information: TFileInformation; var FileFindAct: TFileFindAct);
    procedure SubFolderFileListing(SearchDir: String);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function NormalFileListing(SearchDir: String; ResultList: TStrings): Integer;
    function AllFileListing(SearchDir: String; ResultList: TStrings): Integer;
    function FolderFileListing(SearchDir: String; ResultList: TStrings): Integer;

    function NormalFileSearch(SearchDir: String): Boolean;
    function AllFileSearch(SearchDir: String): Boolean;
    function FolderSearch(SearchDir: String): Boolean;

    procedure SubFolderFileSearch(SearchDir: String);

    property OnFileFind: TFileFindEvent read FOnFileFind write FOnFileFind;
    property FileListingNow: Boolean read FFileListingNow default false;
  end;

implementation

{ TFileListing }

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

destructor TFileListing.Destroy;
begin
  inherited;
end;


////////////////////////////////////////////////////////////
//ファイル名列挙関数のベース
////////////////////////////////////////////////////////////
{
呪文みたいなものなので、中身は気にしなくてよいでしょう。
これを呼び出している他の関数を使えばよいのです。

FileTypeやMethodはそれぞれの型を参照
SerchDirはディレクトリ名、最後に\記号は不必要...あっても大丈夫
WildCardは『*.*』形式
AttrはFindFirstのヘルプ参照『faAnyFile』や『faAnyFile-faDirectory』という風に指定
戻り値はTrueなら処理成功falseなら失敗
}

function TFileListing.FileListingBase(
 FileType: TListingFileType; Method: TMethodMode;
 SearchDir, WildCard: String; Attr: Integer; ResultList: TStrings): Boolean;

    function LastDelimiterDelete(FolderName: String): String;
    begin
      Result := FolderName;
      if Length(FolderName) = LastDelimiter('\', FolderName) then
      begin  {最後の区切り文字\が文字列と同じ長さのとこにある場合}
        Result := Copy(FolderName, 1, Length(FolderName)-1); {左から一つ削除}
      end;
    end;

    function FoundFile(SRec: TSearchRec): TFileFindAct;
    var
      FileInfo1: TFileInformation;
    begin
      case Method of
        mmListing:
        begin
          if ResultList <> nil then
            ResultList.Add(SearchDir +'\'+ SRec.Name);
          Result := faContinue;
        end;
        mmSearch:
        begin
          FileInfo1.FullPathName := SearchDir +'\'+ SRec.Name;
          FileInfo1.Size := SRec.Size;
          FileInfo1.Time := SRec.Time;
          FileFind(FileInfo1, Result);  {イベント発生}
          if Result = faStop then
            FFileListingNow := false;
        end;
      end;

    end;

var
  SearchRec1: TSearchRec;
begin
  Result := true;
  if not DirectoryExists(SearchDir) then Exit;
  if not FFileListingNow then exit;

  SearchDir := LastDelimiterDelete(SearchDir);

  try           {FindFirstは何も見つからないと0以外を返すので必ずこうする}
    if FindFirst( SearchDir +'\'+ WildCard, Attr, SearchRec1) <> 0 then exit;
    repeat            {ExitせずにFindCloseを読んではいけない}
      if (SearchRec1.Name = '') then
        Exit;

      if (SearchRec1.Name <> '.')
         and (SearchRec1.Name <> '..') then
        case FileType of
          flNormal:           {Normalならイベント発生}
            begin
              if FoundFile(SearchRec1) = faStop then
                Break;
            end;
          flFolder:
            if (SearchRec1.Attr and faDirectory>0) then
            begin              {Folderなら再度フォルダと確認してからイベント発生}
              if FoundFile(SearchRec1) = faStop then
                Break; {イベントからの戻り値で検索を停止する事が可能。}
            end;
        end;

    until not ( FindNext(SearchRec1)=0 );
  except
    Result := false;
  end;
  FindClose( SearchRec1 );
end;

////////////////////////////////////////////////////////////
//ファイルサーチ
//失敗するとfalseが返る

{ノーマルファイル(Folderではない)を検索}
{ ファイルが見つかるたびにFileFindEventにしていされたprocedureが呼び出される}
function TFileListing.NormalFileSearch(SearchDir: String): Boolean;
begin
  FFileListingNow := true;
  Result :=  FileListingBase(flNormal, mmSearch, SearchDir, '*.*',
               faAnyFile - (faDirectory or faSysFile), nil);
  FFileListingNow := false;
end;

{AllFile(Folderファイルも含む)を検索}
function TFileListing.AllFileSearch(SearchDir: String): Boolean;
begin
  FFileListingNow := true;
  Result := FileListingBase(flNormal, mmSearch, SearchDir, '*.*',
               faAnyFile, nil);
  FFileListingNow := false;
end;

{FolderFileを検索}
function TFileListing.FolderSearch(SearchDir: String): Boolean;
begin
  FFileListingNow := true;
  Result := FileListingBase(flFolder, mmSearch, SearchDir, '*.*',
               faDirectory or faSysFile, nil);
  FFileListingNow := false;
end;


////////////////////////////////////////////////////////////
//ファイルリスティング
function TFileListing.NormalFileListing(SearchDir: String;
  ResultList: TStrings): Integer;
begin
  FFileListingNow := true;
  ResultList.Clear;
  if FileListingBase(flNormal, mmListing, SearchDir, '*.*',
        faAnyFile - (faDirectory or faSysFile), ResultList) = false then
    ShowMessage('正常にファイル列挙を完了できませんでした');
  Result := ResultList.Count;
  FFileListingNow := false;
end;


function TFileListing.AllFileListing(SearchDir: String;
  ResultList: TStrings): Integer;
begin
  FFileListingNow := true;
  ResultList.Clear;
  if FileListingBase(flNormal, mmListing, SearchDir, '*.*',
        faAnyFile, ResultList) = false then
    ShowMessage('正常にファイル列挙を完了できませんでした');
  Result := ResultList.Count;
  FFileListingNow := false;
end;

function TFileListing.FolderFileListing(SearchDir: String;
  ResultList: TStrings): Integer;
begin
  FFileListingNow := true;
  ResultList.Clear;
  if FileListingBase(flFolder, mmListing, SearchDir, '*.*',
        (faDirectory or faSysFile), ResultList) = false then
    ShowMessage('正常にファイル列挙を完了できませんでした');
  Result := ResultList.Count;
  FFileListingNow := false;
end;

////////////////////////////////////////////////////////////
//サブフォルダサーチ
procedure TFileListing.SubFolderFileSearch(SearchDir: String);
begin
  FFileListingNow := true;
  SubFolderFileListing(SearchDir);
  FFileListingNow := false;
end;

procedure TFileListing.SubFolderFileListing(SearchDir: String);

    function Sub_NormalFileSearch(SearchDir: String): Boolean;
    begin
      Result :=  FileListingBase(flNormal, mmSearch, SearchDir, '*.*',
                   faAnyFile - (faDirectory or faSysFile), nil);
    end;

    function Sub_FolderFileListing(SearchDir: String;
      ResultList: TStrings): Integer;
    begin
      ResultList.Clear;
      if FileListingBase(flFolder, mmListing, SearchDir, '*.*',
            (faDirectory or faSysFile), ResultList) = false then
        ShowMessage('正常にファイル列挙を完了できませんでした');
      Result := ResultList.Count;
    end;

var
  i: Integer;
  StringList1: TStringList;
begin
  if not FFileListingNow then exit;

  StringList1 := TStringList.Create;

  Sub_NormalFileSearch(SearchDir);{ここでイベントが発生}

  if Sub_FolderFileListing(SearchDir, StringList1) > 0 then
  begin
    for i := 0 to StringList1.Count - 1 do
    begin
      if DirectoryExists(StringList1[i]) then
        SubFolderFileListing(StringList1[i]);
    end;  {再帰}
  end;

  StringList1.Free;
end;


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

end.