[Delphi] 条件に一致するファイルをサブフォルダも探す

2005年11月22日(火) 17:23 JST
投稿者:くろねこ

条件に合致するファイルを探し出し、見つかったファイルに対して何か作業ができるようにイベントを発生させています。
指定フォルダ以下のサブフォルダに対しても検索をかけています。サブフォルダの階層を制限する場合や、サブフォルダの検索が不要な際には、イベント中で DigDir 引数に対し False を返すとそれ以上のサブフォルダを処理しません。
見つかったときの処理を直コーディングせずにイベントにしたことでクラス化が行え、再利用性が高まっています。別にライブラリでもよかったのですが、コンポーネントのほうが視覚的に見えてダブルクリックでコーディングしていけるので皆さんに使ってもらいやすいかな？というぐらいのものです。

利用方法：

FileMask
見つけるべき対象のファイルとそうでないファイルとを分けるフィルタ文字列を設定します。
フィルタ文字列の設定方法は Mask ユニットの TMask の記述を参照してください。
Root
検索対象フォルダの最上位のフォルダを指定します。
実行の際最初に一度だけ参照されます。
OnFound
ファイルが見つかった場合、サブフォルダが見つかった場合に起こるイベントです。
詳細はコメントを参考にしてください。

unit DigDir;

interface

uses
  SysUtils, Classes, Masks;

const
  DefaultMaskStr = '*.*';

type
  /// ファイル/フォルダ発見時のコールバック関数
  /// 見つけたパス
  /// ファイルかどうか(ファイル=True)
  /// 掘り進んだレベル(Root=0)
  /// フォルダの場合掘るかどうか
  /// 処理中断
  TFoundEvent = procedure(const Path: string;
                          const IsFile: Boolean;
                          const Level: integer;
                          var DigDir: Boolean;
                          var Cancel: Boolean)
                          of object;

  TDigDirectory = class(TComponent)
  private
    FFileMaskStr: string;
    FFileMask: TMask;
    FRoot: string;
    FOnFound: TFoundEvent;
    /// ファイル検索マスク設定
    /// マスクパターン文字列
    procedure SetFileMask(const Value: string);
    /// フォルダ検索
    procedure DigDirectory(const DirPath: string; const Level: integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    /// フォルダ検索
    procedure Execute();
  published
    /// ファイル検索マスク文字列
    property FileMask: string read FFileMaskStr write SetFileMask;
    /// 検索ルートフォルダ
    property Root: string read FRoot write FRoot;
    /// 条件に一致するファイルが見つかった場合のイベント
    property OnFound: TFoundEvent read FOnFound write FOnFound;
  end;

procedure Register;

implementation

{ TDigDirectory }

constructor TDigDirectory.Create(AOwner: TComponent);
begin
  inherited;
  SetFileMask(DefaultMaskStr);
end;

destructor TDigDirectory.Destroy;
begin
  inherited;
  FreeAndNil(FFileMask);
end;

procedure TDigDirectory.Execute();
begin
  DigDirectory(FRoot, 0);
end;

procedure TDigDirectory.DigDirectory(const DirPath: string; const Level: integer);
var
  Rec: TSearchRec;
  Path: string;
  DigDir, Cancel: Boolean;
begin
  Cancel := false;

  Path := IncludeTrailingPathDelimiter(DirPath);                //  付け
  if FindFirst(Path  + '*.*', faAnyFile, Rec) = 0 then      // 初回検索
  begin
    // 見つかった
    try
      repeat
        // フォルダ発見
        if (Rec.Attr and faDirectory > 0) and (Rec.Name <> '.') and (Rec.Name <> '..') then
        begin
          // 通知
          DigDir := true;
          if Assigned(FOnFound) then
            FOnFound(Path + Rec.Name, false, Level, DigDir, Cancel);
          // キャンセルの場合
          if Cancel then break;
          // さらに掘る場合
          if DigDir then DigDirectory(Path + Rec.Name, Level + 1);
        end
        // ファイル発見
        else
        if (Rec.Name <> '.') and (Rec.Name <> '..') and (FFileMask.Matches(Rec.Name)) then
        begin
          // 通知
          if Assigned(FOnFound) then
            FOnFound(Path + Rec.Name, true, Level, DigDir, Cancel);
          if Cancel then break;                             // キャンセルの場合
        end;
      until (FindNext(Rec) <> 0);
    finally
      FindClose(Rec);                                       // 解放
    end;
  end;
end;

procedure TDigDirectory.SetFileMask(const Value: string);
var
  NewMaskStr: String;
  OldMask: TMask;
begin
  if (Value = '') then
    NewMaskStr := DefaultMaskStr
  else
    NewMaskStr := Value;
  if (FFileMaskStr = NewMaskStr) then exit;

  OldMask := FFileMask;
  try
    FFileMask := TMask.Create(NewMaskStr);
    FFileMaskStr := NewMaskStr;
  except
    FFileMask := OldMask;
  end;
end;

procedure Register;
begin
  RegisterComponents('Black Cat', [TDigDirectory]);
end;

end.

コメント (0件)

くろねこ研究所: https://www.blackcat.xyz/article.php/ProgramingFAQ_del0061