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

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

property Dirs: TStrings; protected; 

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

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

property ScanDirs: TScanDirs; protected;

property Wildcards: TStrings; protected;

*.wav
*.mp3

property Recurse: Boolean; protected;

property Attributes: TFileAttributes; protected;

property MaxThreads: Cardinal; protected;

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

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

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

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

procedure Terminate; public;

function Scaning: Boolean; public;

property Pause: Boolean; public;

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.