TFileFinder - механизм поиска файлов

Было дело, надо было создать компонент, котрый производит поиск файлов. Он был создан и в периодически дополнялся новыми возможностями. Вот и получился компонент с огромными возможностями. Единственное "но" - он был опробован только на Delphi 5 + WinNT 4.0 SP6. Но !должен! без проблем работать и в других средах....

Краткие характеристики

Компонент позволет производить поиск как на локальных дисках так и в локаольной сети.

Компонент использует многопотоковость.

• Для сканирования локальных дисков используется отдельный поток, что позволяет продолжать выполнение программы.
• Для сканирования удаленных компьютеров используется по одному потоку на каждый компьютер. То есть одновременно позволяет сканировать хоть все компьтеры сети.

Это усовершенствование должно заметно если не сказать "КОНКРЕТНО" повышает скорость сканирования.

Фильтрование файлов. Гарантируется, что один и тот же файл не будет дважды и более возвращен. Это может случиться при поиске файлов по нескольким маскам (Например поиск ведется по маскам [some*.*] и [*.txt] в этом случае файл somebody.txt попадает в две котегории)

Компонент ведет статистику:

• Кол-во найденых файлов.
• Кол-во просканированых директорий.
• Время проведенное в сканировании файлов (паузы исключаются).
• Время начала и конца сканирования.

Описание

Имя: TCustomFileFinder.

procedure DoFindFile(var FileInfo: TFileInfo); virtual; protected;

Вызывает OnFindFile. Может быть отменена в производных классах.

procedure DoScanDir(const Dir: string); virtual; protected;

Вызывает OnScanDirectory. Может быть отменена в производных классах.

property Dirs: TStrings; protected; 

Содержит список директорий в которых будет производиться посик.

Понимает следующие выражения:

[Drive:][][Dir[]] - Поиск в каталоге на локальном диске
\ - Поиск во всех ресурсах каждого компьютера в сети
\[Computer][] - Поиск во всех ресурсах определенного компьютера в сети
\[Computer][Share][] - Поиск в данном ресурсе определенного компьютера в сети

Комментарий:

Список используется только при ScanDirs равном sdOther.

Замечание:

Если указываются подкаталоги то при в включеной рекурсии они игнорируются.

Пример:

Указан поиск в c: emp

\ 
\server <== (*)
d:win95
d:win95	emp <== (*) 

Каталоги (*) будут игнориорваться т.к. [\server] входит в множество [\], а [d:win95 emp] входит в [d:win95]

property ScanDirs: TScanDirs; protected;

Указывает, где будет производиться поиск.

• sdOther - каталоги указаны в перменной Dirs
• sdCurrentDir - В текущей директории
• sdCurrentDrive - На текущем диске (диск откуда запускалась программа,

но не где находится исполняемый файл)

• sdFixedDrives - Только на жестких дисках (исключаются дискеты, CDROM, сетевые диски и т.п.)
• sdAllDrives - На всех дисках которые присутсвеют в системе
• sdAllNetwork - По всем ресурсам сети (исключаются локальные ресурсы)

property Wildcards: TStrings; protected;

Содержит список масок по которым будет производиться поиск файлов.

Например: Поиск всех файлов с расширением WAV и MP3:

*.wav
*.mp3

property Recurse: Boolean; protected;

Если True, то поиск также будет производиться в поддиректориях.

property Attributes: TFileAttributes; protected;

Указываются атрибуты искомых файлов.

Например:

[faArchive, faReadOnly] - будут найдены файлы у которых нет установленных атрибутов и файлы у которых установлены аттрибуты faArchive или faReadOnly или оба вместе.

property MaxThreads: Cardinal; protected;

Указывает максимальное количество одновременно работающих потоков. 0 - нет ограничений.

Комментарий:

Используется при поиске в локальной сети. Оптимальное значение не найдено. Но при малом значениии снижается скорость поиска, а при большом наблюдается большая загрузка ресурсов компьютера. Для поиска на локальных дисках используется один поток, т. к. использование нескольких потоков сколь нибудь заметного прироста производительности не дадут.

property OnFindFile(Sender: TObject; var FileInfo: TFileInfo); protected; event;

Вызывается если файл отвечающий условиям поиска найден.

Информация о файле содержиться в структуре FileInfo;

Время обработки этого события старайтесь сделать как можно меньше, т. к. поиск файлов вызывающий поток возобонвит только после возврата из из события.

property OnScanDirectory(Sender: TObject; const Dir: string); protected; event;

Вызывается перед поиском файлов в директории Dir.

Не вижу сколь нибудь пользы от этого обработчика, кроме информационной. Можно пользователю показать, где в данные момент производиться поиск.

property OnEndScan(Sender: TObject; Terminated: Boolean); protected; event;

Вызывается после того как все потоки завершили свою работу.

procedure Start(Wait: Boolean = False); public;

Собственно дает команду начать поиск.

Если Wait = True, то процедура вернет управление только когда полностью закончиться поиск. Иначе функция сразу вернет управление. Если уже идет поиск, то выбрасывается исклчение.

procedure Terminate; public;

Прерывавает поиск. Если поиск не происходит, то выбрасывается исклчение.

function Scaning: Boolean; public;

Если возвращает True, то компонент осуществляет поиск.

property Pause: Boolean; public;

Присваивание этому свойству True, приостанавливает поиск.

Присваивание этому свойству False, возобновляет поиск.

Статистика

property Stat_DateTimeBegin: TDateTime; public; - время начала поиска (*)
property Stat_DateTimeEnd: TDateTime; public; - время окончания поиска (**)
property Stat_ScaningTime: TDateTime; public; - время сканирования (**)
property Stat_ScanedFiles: Integer; public; - количество найденных файлов
property Stat_ScanedDirs: Integer; public; - количество просмотренных директорий

(*) статистическая переменная доступны после начала поиска
(**) статистические переменные доступны после окончания поиска

unit FileFinder;

interface

uses
  Windows, SysUtils, Classes;

type
  EFileFinderError = class(Exception);

  TFileAttribute = (faArchive, faReadOnly, faHidden, faSystem,
  faCompressed, faOffline, faTemporary);
  TFileAttributes = set of TFileAttribute;
  TScanDirs = (sdOther, sdCurrentDir, sdCurrentDrive, sdFixedDrives,
  sdAllDrives, sdAllNetwork);

  PFileInfo = ^TFileInfo;
  TFileInfo = record
    FileName: string;
    FileSize: Longword;
    Attributes: TFileAttributes;
    CreationTime: TDateTime;
    ModifyTime: TDateTime;
    LastAccessTime: TDateTime;
  end;

  TFindFileEvent = procedure(Sender: TObject; var FileInfo: TFileInfo) of object;
  TScanDirEvent = procedure(Sender: TObject; const Dir: string) of object;
  TEndScanEvent = procedure(Sender: TObject; Terminated: Boolean) of object;
  TCustomFileFinder = class(TComponent)
  private
    FThrManager: Pointer;
    FScanDirs: TScanDirs;
    FDirs: TStrings;
    FWildcards: TStrings;
    FRecurse: Boolean;
    FAttributes: TFileAttributes;
    FMaxThreads: Cardinal;
    FOnFindFile: TFindFileEvent;
    FOnScanDir: TScanDirEvent;
    FOnEndScan: TEndScanEvent;

    FStat_BeginTime: TDateTime;
    FStat_EndTime: TDateTime;
    FStat_IncTime: TDateTime;
    FStat_BegScan: TDateTime;
    FStat_NumFiles: Integer;
    FStat_NumDirs: Integer;

    function GetPause: Boolean;
    procedure SetPause(Value: Boolean);
    procedure SetDirs(Value: TStrings);
    procedure SetScanDirs(Value: TScanDirs);
    procedure SetWildcards(Value: TStrings);
    procedure SetRecurse(Value: Boolean);
    procedure SetAttributes(Value: TFileAttributes);
    procedure SetMaxThreads(Value: Cardinal);
    procedure FindFileCB(var FileInfo: TFileInfo);
    procedure ScanDirCB(const Dir: string);
    procedure TMTerminated;
    function GetStat_DateTimeBegin: TDateTime;
    function GetStat_DateTimeEnd: TDateTime;
    function GetStat_ScaningTime: TDateTime;
    protected
    procedure DoFindFile(var FileInfo: TFileInfo); virtual;
    procedure DoScanDir(const Dir: string); virtual;

    property Dirs: TStrings read FDirs write SetDirs;
    property ScanDirs: TScanDirs read FScanDirs write SetScanDirs;
    property Wildcards: TStrings read FWildcards write SetWildcards;
    property Recurse: Boolean read FRecurse write SetRecurse default TRUE;
    property Attributes: TFileAttributes read FAttributes write SetAttributes;
    property MaxThreads: Cardinal read FMaxThreads write SetMaxThreads;
    property OnFindFile: TFindFileEvent read FOnFindFile write FOnFindFile;
    property OnScanDirectory: TScanDirEvent read FOnScanDir write FOnScanDir;
    property OnEndScan: TEndScanEvent read FOnEndScan write FOnEndScan;
  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;
    procedure Start(Wait: Boolean = False);
    procedure Terminate;
    function Scaning: Boolean;
    property Pause: Boolean read GetPause write SetPause;

    property Stat_DateTimeBegin: TDateTime read GetStat_DateTimeBegin;
    property Stat_DateTimeEnd: TDateTime read GetStat_DateTimeEnd;
    property Stat_ScaningTime: TDateTime read GetStat_ScaningTime;
    property Stat_ScanedFiles: Integer read FStat_NumFiles;
    property Stat_ScanedDirs: Integer read FStat_NumDirs;
  end;

  TFileFinder = class(TCustomFileFinder)
  published
    property Dirs;
    property ScanDirs;
    property Wildcards;
    property Recurse;
    property Attributes;
    property MaxThreads;
    property OnFindFile;
    property OnScanDirectory;
    property OnEndScan;
  end;

procedure register;

implementation

type
  PQueueRecord = ^TQueueRecord;
  TQueueRecord = record
    Dir: string;
    Thread: Pointer;
  end;

  TThreadManager = class
  private
    FWildcards: array of string;
    FTerminated: Boolean;
    FFF: TCustomFileFinder;
    ThreadList: TThreadList;
    TermEvent: THandle;
    FQueue: TThreadList;
    constructor Create(AFF: TCustomFileFinder);
    destructor Destroy; override;
    function GetDir(Sender: TObject): string;
    procedure AddDir(const Dir: string);
    procedure ExamineAndStart;
    procedure Terminate;
    procedure Suspend;
    procedure Resume;
    procedure WaitForAll;
    function GetSuspended: Boolean;
    procedure FFTTerminated(Sender: TObject);
  end;

  TFileFinderThread = class(TThread)
  private
    ThrManager: TThreadManager;
    FilesInfo: array of TFileInfo;
    Bounds: array of Integer;
    FilesCount: Integer;
    CurFileInfo: PFileInfo;
    CurrentDir: string;
    ProcFileName: string;
    ProcFileAttr: Cardinal;
    NetRes: TNetResource;
    ServerProc: string;

    procedure EnumNetRes(Ptr: PNetResource);
    function PartNetworkPath(const Dir: string): Boolean;
    function TestFile(var ft: TFileAttributes): Boolean;
    procedure WildcardProc(const Wildcard: string);
    procedure DirProc(const Dir: string);
    function SubSearch(Low, High: Integer): Boolean;
    function SearchFile: Boolean;
    procedure IncFilesCount;
    procedure SafeCallFind;
    procedure SafeCallNotify;
  protected
    procedure DoTerminate; override;
    procedure Execute; override;
  public
    constructor Create(ATM: TThreadManager);
  end;

resourcestring
  NamePalette = 'Tadex''s Components';
  ScaningProcessError = 'Scaning in progress. Can not change this parameter.';
  ProcThreadError = 'Scaning don''t started';
  BeginScaningError = 'Scaning already in progress.';
  StatNotCollected = 'This statistic information isn''t collected yet';

function DrivePath(Letter: char): string;
begin
  Result := Letter + ':';
end;

function MakePath(const Path, FileName: string): string;
begin
  if Path[Length(Path)] = '' then
    Result := Concat(Path, FileName)
  else
    Result := Concat(Path, '', FileName);
end;

function ExtractServerName(const UNCPath: string): string;
var
  DelimPos: Integer;
begin
  Result := '.';
  if (UNCPath[1] <> '') or (UNCPath[2] <> '') then
    Exit;
  Result := Copy(UNCPath, 3, Length(UNCPath) - 2);
  DelimPos := Pos('', Result);
  if DelimPos > 0 then
    Result := Copy(Result, 1, DelimPos - 1);
  if Result = '' then
    Result := '*';
end;

function ExpandPath(const Path: string): string;
var
  Dir, Drive, name: string;
  i, Count: Integer;
  Dirs: array [0..127] of string;
  Buffer: array [0..MAX_PATH - 1] of Char;
  FName: PChar;
  FD: WIN32_FIND_DATA;
  HDir: THandle;
  NxtFile: Boolean;
begin
  Result := '';
  SetString(Dir, Buffer, GetFullPathName(PChar(Path),
  SizeOf(Buffer), Buffer, FName));
  Drive := ExtractFileDrive(Dir);
  Count := 0;
  for i := Low(Dirs) to High(Dirs) do
  begin
    if (Length(Dir) = 3) or (Length(Dir) = Length(Drive)) then
      Break;
    name := ExtractFileName(Dir);
    Dir := ExtractFileDir(Dir);
    if name <> '' then
    begin
      Dirs[Count] := name;
      Inc(Count);
    end;
  end;
  if Count > 0 then
    Dir := Drive;
  name := UpperCase(Dir);
  for i := Count - 1 downto 0 do
  begin
    Dir := Concat(Dir, '', Dirs[i]);
    HDir := FindFirstFile(PChar(Dir), FD);
    if HDir = INVALID_HANDLE_VALUE then
      Exit;
    try
      NxtFile := FindNextFile(HDir, FD);
    finally
      Windows.FindClose(HDir);
    end;
    if NxtFile then
      Exit;
    if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then
      Exit;
    name := Concat(name, '', FD.cFileName);
  end;
  Result := name;
end;

function FT2DT(FileTime: TFileTime): TDateTime;
var
  LocalFileTime: TFileTime;
  Tmp: Int64;
begin
  FileTimeToLocalFileTime(FileTime, LocalFileTime);
  with Int64Rec(Tmp), LocalFileTime do
  begin
    Hi := dwHighDateTime;
    Lo := dwLowDateTime;
  end;
  Result := (Tmp - 94353120000000000) / 8.64e11;
end;

function LowBound(Arr: array of Integer; index: Integer): Integer;
begin
  if index = 0 then
    Result := 0
  else
    Result := Arr[index - 1];
end;

constructor TFileFinderThread.Create(ATM: TThreadManager);
begin
  inherited Create(True);
  FreeOnTerminate := True;
  ThrManager := ATM;
  SetLength(Bounds, Length(ThrManager.FWildcards));
  SetLength(FilesInfo, 8);
  ServerProc := '';
  with NetRes do
  begin
    dwScope := RESOURCE_GLOBALNET;
    dwType := RESOURCETYPE_DISK;
    dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;
    dwUsage := RESOURCEUSAGE_CONTAINER;
    lpLocalName := '';
    lpComment := '';
    lpProvider := '';
  end;
end;

procedure TFileFinderThread.SafeCallFind;
begin
  ThrManager.FFF.FindFileCB(CurFileInfo^);
end;

procedure TFileFinderThread.SafeCallNotify;
begin
  ThrManager.FFF.ScanDirCB(CurrentDir);
end;

function TFileFinderThread.SubSearch(Low, High: Integer): Boolean;
var
  Tmp: Integer;
begin
  Tmp := High - Low;
  if Tmp <= 0 then
    Result := False
  else
  if Tmp = 1 then
    Result := FilesInfo[Low].FileName = ProcFileName
  else
  begin
    Tmp := Low + Tmp div 2;
    if FilesInfo[Tmp].FileName <= ProcFileName then
      Result := SubSearch(Tmp, High)
    else
      Result := SubSearch(Low, Tmp);
  end;
end;

function TFileFinderThread.SearchFile: Boolean;
var
  i: Integer;
begin
  Result := True;
  for i := 0 to High(Bounds) do
    if SubSearch(LowBound(Bounds, i), Bounds[i]) then
      Exit;
  Result := False;
end;

function TFileFinderThread.TestFile(var FT: TFileAttributes): Boolean;
begin
  Result := False;
  FT := [];
  if ProcFileAttr and FILE_ATTRIBUTE_DIRECTORY <> 0 then
    Exit;
  if ProcFileAttr and FILE_ATTRIBUTE_ARCHIVE <> 0 then
    Include(FT, faArchive);
  if ProcFileAttr and FILE_ATTRIBUTE_READONLY <> 0 then
    Include(FT, faReadOnly);
  if ProcFileAttr and FILE_ATTRIBUTE_HIDDEN <> 0 then
    Include(FT, faHidden);
  if ProcFileAttr and FILE_ATTRIBUTE_SYSTEM <> 0 then
    Include(FT, faSystem);
  if ProcFileAttr and FILE_ATTRIBUTE_COMPRESSED <> 0 then
    Include(FT, faCompressed);
  if ProcFileAttr and FILE_ATTRIBUTE_TEMPORARY <> 0 then
    Include(FT, faTemporary);
  if ProcFileAttr and FILE_ATTRIBUTE_OFFLINE <> 0 then
    Include(FT, faOffline);
  Result := ((FT * ThrManager.FFF.FAttributes <> [])
  or (FT = [])) and not SearchFile;
end;

procedure TFileFinderThread.IncFilesCount;
begin
  Inc(FilesCount);
  if FilesCount >= Length(FilesInfo) then
    SetLength(FilesInfo, Length(FilesInfo) * 3 div 2);
end;


procedure TFileFinderThread.WildcardProc(const Wildcard: string);
var
  FD: WIN32_FIND_DATA;
  Files: THandle;
  Attr: TFileAttributes;
begin
  if Terminated then
    Exit;
  Files := FindFirstFile(PChar(Wildcard), FD);
  if Files <> INVALID_HANDLE_VALUE then
    try
      repeat
        ProcFileName := FD.cFileName;
        ProcFileAttr := FD.dwFileAttributes;
        if TestFile(Attr) then
          with FilesInfo[FilesCount], FD do
          begin
            FileName := ProcFileName;
            FileSize := nFileSizeLow;
            Attributes := Attr;
            CreationTime := FT2DT(ftCreationTime);
            ModifyTime := FT2DT(ftLastWriteTime);
            LastAccessTime := FT2DT(ftLastAccessTime);
            IncFilesCount;
          end
      until
        Terminated or not FindNextFile(Files, FD)
    finally
      Windows.FindClose(Files);
    end
end;

procedure TFileFinderThread.EnumNetRes(Ptr: PNetResource);
type
  PNetResArray = ^TNetResArray;
  TNetResArray = array[0..MaxInt div sizeof(TNetResource) - 1] of TNetResource;
var
  I, BufSize, NetResult: Integer;
  Count, Size: LongWord;
  NetHandle: THandle;
  NetResources: PNetResArray;
begin
  if Terminated then
    Exit;
  if WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,
  0, Ptr, NetHandle) <> NO_ERROR then
    Exit;
  NetResources := nil;
  try
    BufSize := 10 * SizeOf(TNetResource);
    GetMem(NetResources, BufSize);
    repeat
      Count := $FFFFFFFF; Size := BufSize;
      NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
      if NetResult <> ERROR_MORE_DATA then
        Break;
      BufSize := Size;
      ReallocMem(NetResources, BufSize);
    until
      False;
    if NetResult = NO_ERROR then
      for I := 0 to Count - 1 do
        with NetResources^[I] do
          if dwDisplayType in [RESOURCEDISPLAYTYPE_SHARE,
          RESOURCEDISPLAYTYPE_SERVER] then
            ThrManager.AddDir(lpRemoteName)
          else
          if (dwUsage and RESOURCEUSAGE_CONTAINER) =
          RESOURCEUSAGE_CONTAINER then
            EnumNetRes(@NetResources^[I]);
  finally
    if NetResources <> nil then
      FreeMem(NetResources);
    WNetCloseEnum(NetHandle);
  end;
end;

function TFileFinderThread.PartNetworkPath(const Dir: string): Boolean;
begin
  Result := False;
  if (Length(Dir) < 2) or (Dir[1] <> '') or (Dir[2] <> '') then
    Exit;
  if (Length(Dir) > 2) and (LastDelimiter('', Dir) > 2) then
    Exit;
  if Length(Dir) = 2 then
    EnumNetRes(nil)
  else
  begin
    NetRes.lpRemoteName := PChar(Dir);
    EnumNetRes(@NetRes);
  end;
  Result := True;
end;

procedure TFileFinderThread.DirProc(const Dir: string);
var
  FD: WIN32_FIND_DATA;
  Dirs: THandle;
  i: Integer;
begin
  if Terminated then
    Exit;
  CurrentDir := Dir;
  Synchronize(SafeCallNotify);
  if PartNetworkPath(Dir) then
    Exit;
  FilesCount := 0;
  for i := 0 to High(Bounds) do
    Bounds[i] := -1;
  for i := 0 to High(ThrManager.FWildcards) do
  begin
    WildcardProc(MakePath(Dir, ThrManager.FWildcards[i]));
    Bounds[i] := FilesCount;
  end;
  for i := 0 to FilesCount - 1 do
  begin
    if Terminated then
      Exit;
    CurFileInfo := @FilesInfo[i];
    with CurFileInfo^ do
    begin
      FileName := MakePath(Dir, FileName);
      Synchronize(SafeCallFind);
      FileName := '';
    end;
  end;
  if ThrManager.FFF.FRecurse and not Terminated then
  begin
    Dirs := FindFirstFile(PChar(MakePath(Dir, '*.*')), FD);
    if Dirs <> INVALID_HANDLE_VALUE then
      try
        repeat
          with FD do
            if ((dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) and
            (cFileName <> string('.')) and (cFileName <> string('..')) then
              DirProc(MakePath(Dir, cFileName));
        until
          Terminated or not FindNextFile(Dirs, FD);
      finally
        Windows.FindClose(Dirs);
      end
  end
end;

procedure TFileFinderThread.Execute;
var
  Dir: string;
begin
  repeat
    Dir := ThrManager.GetDir(Self);
    if Dir = '' then
      Break;
    DirProc(Dir);
  until
    Terminated;
end;

procedure TFileFinderThread.DoTerminate;
begin
  ThrManager.FFTTerminated(Self);
end;

constructor TThreadManager.Create(AFF: TCustomFileFinder);
var
  i, j, Count: Integer;
  ch: Char;
  Dirs: array of string;
begin
  inherited Create;
  FFF := AFF;
  FTerminated := False;
  FQueue := TThreadList.Create;
  ThreadList := TThreadList.Create;
  TermEvent := CreateEvent(nil, False, False, nil);
  SetLength(FWildcards, FFF.Wildcards.Count);
  Count := 0;
  for i := 0 to High(FWildcards) do
    if Trim(FFF.Wildcards.Strings[i]) <> '' then
    begin
      FWildcards[Count] := FFF.Wildcards.Strings[i];
      Inc(Count);
    end;
  SetLength(FWildcards, Count);
  SetLength(Dirs, FFF.FDirs.Count);
  for i := 0 to High(Dirs) do
    Dirs[Count] := FFF.FDirs.Strings[i];
  case FFF.FScanDirs of
    sdOther:
    begin
      for i := 0 to High(Dirs) do
        Dirs[i] := ExpandPath(Dirs[i]);
      for i := 0 to High(Dirs) do
        for j := 0 to High(Dirs) do
          if (i <> j) and (Dirs[i] <> '') and (Dirs[j] <> '') then
            if FFF.FRecurse then
            begin
              if Pos(Dirs[j], Dirs[i]) > 0 then
                Dirs[i] := '';
            end
            else
            begin
              if Dirs[i] = Dirs[j] then
                Dirs[i] := '';
            end;
      for i := 0 to High(Dirs) do
        if Dirs[i] <> '' then
          AddDir(Dirs[i]);
    end;
    sdCurrentDir:
      AddDir(GetCurrentDir);
    sdCurrentDrive:
      AddDir(DrivePath(GetCurrentDir[1]));
    sdAllNetwork:
      AddDir('');
    else
      for ch := 'A' to 'Z' do
        case GetDriveType(PChar(DrivePath(ch))) of
          DRIVE_REMOVABLE, DRIVE_REMOTE, DRIVE_CDROM:
            if FFF.FScanDirs = sdAllDrives then
              AddDir(DrivePath(ch));
          DRIVE_FIXED:
            if FFF.FScanDirs in [sdAllDrives, sdFixedDrives] then
              AddDir(DrivePath(ch));
        end;
  end;
end;

destructor TThreadManager.Destroy;
begin
  Terminate;
  WaitForAll;
  CloseHandle(TermEvent);
  ThreadList.Free;
  FQueue.Free;
  inherited Destroy;
end;

procedure TThreadManager.Terminate;
var
  List: TList;
  i: Integer;
begin
  FTerminated := True;
  List := ThreadList.LockList;
  for i := 0 to List.Count - 1 do
    with TFileFinderThread(List.Items[i]) do
    begin
      Suspended := False;
      Terminate;
    end;
  ThreadList.UnlockList;
end;

procedure TThreadManager.Suspend;
var
  List: TList;
  i: Integer;
begin
  List := ThreadList.LockList;
  for i := 0 to List.Count - 1 do
    TFileFinderThread(List.Items[i]).Suspended := True;
  ThreadList.UnlockList;
end;

procedure TThreadManager.Resume;
var
  List: TList;
  i: Integer;
begin
  List := ThreadList.LockList;
  for i := 0 to List.Count - 1 do
    TFileFinderThread(List.Items[i]).Suspended := False;
  ThreadList.UnlockList;
end;

procedure TThreadManager.WaitForAll;
var
  Msg: TMsg;
  H: THandle;
begin
  H := TermEvent;
  if GetCurrentThreadID = MainThreadID then
    while MsgWaitForMultipleObjects(1, H, False, INFINITE,
    QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do
      PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE)
  else
    WaitForSingleObject(H, INFINITE);
end;

procedure TThreadManager.FFTTerminated(Sender: TObject);
var
  List: TList;
  Termination: Boolean;
begin
  ThreadList.Remove(Sender);
  ExamineAndStart;
  List := ThreadList.LockList;
  Termination := List.Count = 0;
  ThreadList.UnlockList;
  if Termination then
  begin
    SetEvent(TermEvent);
    FFF.TMTerminated;
  end;
end;

function TThreadManager.GetSuspended: Boolean;
var
  List: TList;
  i: Integer;
begin
  Result := False;
  List := ThreadList.LockList;
  for i := 0 to List.Count - 1 do
    Result := Result or TFileFinderThread(List.Items[i]).Suspended;
  ThreadList.UnlockList;
end;

function TThreadManager.GetDir(Sender: TObject): string;
var
  List: TList;
  i: Integer;
  ServerProc: string;
begin
  Result := '';
  List := FQueue.LockList;
  for i := 0 to List.Count - 1 do
    with PQueueRecord(List.Items[i])^ do
      if Thread = Sender then
      begin
        Result := Dir;
        Dispose(List.Items[i]);
        List.Delete(i);
        Break;
      end;
  if Result = '' then
  begin
    ServerProc := '';
    for i := 0 to List.Count - 1 do
      with PQueueRecord(List.Items[i])^ do
        if Thread = nil then
        begin
          ServerProc := ExtractServerName(Dir);
          Result := Dir;
          Dispose(List.Items[i]);
          List.Delete(i);
          Break;
        end;
    if ServerProc <> '' then
    begin
      if Sender is TFileFinderThread then
        TFileFinderThread(Sender).ServerProc := ServerProc;
      for i := 0 to List.Count - 1 do
        with PQueueRecord(List.Items[i])^ do
          if ExtractServerName(Dir) = ServerProc then
            Thread := Sender;
    end;
  end;
  FQueue.UnlockList;
end;

procedure TThreadManager.AddDir(const Dir: string);
var
  i: Integer;
  List: TList;
  QRec: PQueueRecord;
  Caller: TFileFinderThread;
  ServerProc: string;
begin
  ServerProc := ExtractServerName(Dir);
  Caller := nil;
  List := ThreadList.LockList;
  for i := 0 to List.Count - 1 do
    if TFileFinderThread(List.Items[i]).ServerProc = ServerProc then
    begin
      Caller := TFileFinderThread(List.Items[i]);
      Break;
    end;
  ThreadList.UnlockList;
  New(QRec);
  QRec.Dir := Dir;
  QRec.Thread := Caller;
  FQueue.Add(QRec);
  ExamineAndStart;
end;

procedure TThreadManager.ExamineAndStart;
var
  Threads, Queue: TList;
  i: Integer;
  NewThread: TFileFinderThread;
  ServerProc: string;
begin
  if FTerminated then
    Exit;
  Threads := ThreadList.LockList;
  Queue := FQueue.LockList;
  repeat
    ServerProc := '';
    if (FFF.FMaxThreads = 0) or (Cardinal(Threads.Count) < FFF.FMaxThreads) then
    begin
      for i := 0 to Queue.Count - 1 do
        with PQueueRecord(Queue.Items[i])^ do
          if Thread = nil then
          begin
            ServerProc := ExtractServerName(Dir);
            Break;
          end;
      if ServerProc <> '' then
      begin
        NewThread := TFileFinderThread.Create(Self);
        Threads.Add(NewThread);
        NewThread.ServerProc := ServerProc;
        for i := 0 to Queue.Count - 1 do
          with PQueueRecord(Queue.Items[i])^ do
            if ExtractServerName(Dir) = ServerProc then
              Thread := NewThread;
        NewThread.Resume;
      end;
    end;
  until
    ServerProc = '';
  FQueue.UnlockList;
  ThreadList.UnlockList;
end;

constructor TCustomFileFinder.Create(Owner: TComponent);
begin
  inherited Create(Owner);
  FDirs := TStringList.Create;
  FWildcards := TStringList.Create;
  FAttributes := [faArchive, faReadOnly];
  FRecurse := True;
  FScanDirs := sdFixedDrives;
  FMaxThreads := 10;
  FThrManager := nil;
  FWildcards.Add('*.*');
  FStat_BeginTime := 0;
  FStat_EndTime := 0;
  FStat_IncTime := 0;
  FStat_NumFiles := 0;
  FStat_NumDirs := 0;
end;

destructor TCustomFileFinder.Destroy;
begin
  if Assigned(FThrManager) then
    TThreadManager(FThrManager).Free;
  FDirs.Free;
  FWildcards.Free;
  inherited Destroy;
end;

procedure TCustomFileFinder.FindFileCB(var FileInfo: TFileInfo);
begin
  Inc(FStat_NumFiles);
  DoFindFile(FileInfo);
end;

procedure TCustomFileFinder.ScanDirCB(const Dir: string);
begin
  Inc(FStat_NumDirs);
  DoScanDir(Dir);
end;

procedure TCustomFileFinder.DoFindFile(var FileInfo: TFileInfo);
begin
  if Assigned(FOnFindFile) then
    FOnFindFile(self, FileInfo);
end;

procedure TCustomFileFinder.DoScanDir(const Dir: string);
begin
  if Assigned(FOnScanDir) then
    FOnScanDir(self, Dir);
end;

function TCustomFileFinder.Scaning: Boolean;
begin
  Result := Assigned(FThrManager);
end;

procedure TCustomFileFinder.SetDirs(Value: TStrings);
begin
  if Assigned(FThrManager) then
    raise EFileFinderError.Create(ScaningProcessError);
  FDirs.Assign(Value);
  FScanDirs := sdOther;
end;

procedure TCustomFileFinder.SetWildcards(Value: TStrings);
begin
  if Assigned(FThrManager) then
    raise EFileFinderError.Create(ScaningProcessError);
  FWildcards.Assign(Value);
end;

procedure TCustomFileFinder.SetScanDirs(Value: TScanDirs);
begin
  if Assigned(FThrManager) then
    raise EFileFinderError.Create(ScaningProcessError);
  FScanDirs := Value;
end;

procedure TCustomFileFinder.SetRecurse(Value: Boolean);
begin
  if Assigned(FThrManager) then
    raise EFileFinderError.Create(ScaningProcessError);
  FRecurse := Value;
end;

procedure TCustomFileFinder.SetAttributes(Value: TFileAttributes);
begin
  if Assigned(FThrManager) then
    raise EFileFinderError.Create(ScaningProcessError);
  FAttributes := Value;
end;

procedure TCustomFileFinder.SetMaxThreads(Value: Cardinal);
begin
  FMaxThreads := Value;
end;

procedure TCustomFileFinder.Terminate;
begin
  if not Assigned(FThrManager) then
    raise EFileFinderError.Create(ProcThreadError);
  TThreadManager(FThrManager).Terminate;
end;

function TCustomFileFinder.GetPause: Boolean;
begin
  if not Assigned(FThrManager) then
    raise EFileFinderError.Create(ProcThreadError);
  Result := TThreadManager(FThrManager).GetSuspended;
end;

procedure TCustomFileFinder.SetPause(Value: Boolean);
var
  Suspended: Boolean;
begin
  if not Assigned(FThrManager) then
    raise EFileFinderError.Create(ProcThreadError);
  Suspended := TThreadManager(FThrManager).GetSuspended;
  if not Suspended and Value then
  begin
    TThreadManager(FThrManager).Suspend;
    FStat_IncTime := FStat_IncTime + (Now - FStat_BegScan);
  end;
  if Suspended and not Value then
  begin
    FStat_BegScan := Now;
    TThreadManager(FThrManager).Resume;
  end;
end;

procedure TCustomFileFinder.Start(Wait: Boolean);
begin
  if Assigned(FThrManager) then
    raise EFileFinderError.Create(BeginScaningError);
  FStat_BeginTime := Now;
  FStat_BegScan := FStat_BeginTime;
  FStat_IncTime := 0;
  FStat_NumFiles := 0;
  FStat_NumDirs := 0;
  FThrManager := TThreadManager.Create(Self);
  if Wait then
    TThreadManager(FThrManager).WaitForAll;
end;

procedure TCustomFileFinder.TMTerminated;
var
  Tmp: Boolean;
begin
  Tmp := TThreadManager(FThrManager).FTerminated;
  FreeAndNil(FThrManager);
  FStat_EndTime := Now;
  FStat_IncTime := FStat_IncTime + (FStat_EndTime - FStat_BegScan);
  if Assigned(FOnEndScan) then
    FOnEndScan(self, Tmp);
end;

function TCustomFileFinder.GetStat_DateTimeBegin: TDateTime;
begin
  if FStat_BeginTime = 0 then
    raise EFileFinderError.Create(StatNotCollected);
  Result := FStat_BeginTime;
end;

function TCustomFileFinder.GetStat_DateTimeEnd: TDateTime;
begin
  if (FStat_EndTime = 0) or Assigned(FThrManager) then
    raise EFileFinderError.Create(StatNotCollected);
  Result := FStat_EndTime;
end;

function TCustomFileFinder.GetStat_ScaningTime: TDateTime;
begin
  Result := FStat_IncTime;
  if Assigned(FThrManager) and not
  TThreadManager(FThrManager).GetSuspended then
    Result := Result + (Now - FStat_BegScan);
end;

procedure register;
begin
  RegisterComponents(NamePalette, [TFileFinder]);
end;

end.

Другое по теме:

• Программный поиск файлов
• Создание и использование DLL
• Hooks - аспекты реализации