findfile.pas

delphi开发的文件搜索组件。 速度极快。

end;

destructor TTargetFolder.Destroy;
begin
  fFileMasks.Free;
  inherited Destroy;
end;

{ TTargetFolderList }

constructor TTargetFolderList.Create;
begin
  inherited Create;
  fExcludedFiles := TStringList.Create;
end;

destructor TTargetFolderList.Destroy;
var
  Index: Integer;
begin
  fExcludedFiles.Free;
  for Index := Count - 1 downto 0 do
    Items[Index].Free;
  inherited Destroy;
end;

function TTargetFolderList.IndexOfFolder(const Folder: String): Integer;
var
  Index: Integer;
begin
  Result := -1;
  for Index := 0 to Count - 1 do
    if CompareText(Folder, Items[Index].Folder) = 0 then
    begin
      Result := Index;
      Break;
    end;
end;

function TTargetFolderList.AddFolder(const Folder: String): TTargetFolder;
var
  Index: Integer;
  FullPath: String;
begin
  FullPath := AddTrailingBackslash(ExpandUNCFileName(Folder));
  Index := IndexOfFolder(FullPath);
  if Index >= 0 then
    Result := Items[Index]
  else
  begin
    Result := TTargetFolder.Create;
    Result.Folder := FullPath;
    Insert(0, Result);
  end;
end;

function TTargetFolderList.IsExcluded(const Folder, FileName: String): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := ExcludedFiles.Count - 1 downto 0 do
    if FileFullPathMatches(Folder, FileName, ExcludedFiles[I]) then
    begin
      Result := True;
      Exit;
    end;
end;

function TTargetFolderList.GetItems(Index: Integer): TTargetFolder;
begin
  Result := TTargetFolder(inherited Items[Index]);
end;

{ TTargetSearch }

constructor TTargetSearch.Create(Criteria: TSearchCriteria);
begin
  inherited Create;
  TargetFolders := TTargetFolderList.Create;
  Attribute := TAttributeCriteria.Create;
  AttributeEx := TAttributeCriteriaEx.Create;
  TimeStamp := TDateTimeCriteria.Create;
  Size := TSizeCriteria.Create;
  Content := TContentCriteria.Create;
  PrepareTargetFolders(Criteria.Files);
  Attribute.Assign(Criteria.Attribute);
  AttributeEx.Assign(Criteria.AttributeEx);
  TimeStamp.Assign(Criteria.TimeStamp);
  Size.Assign(Criteria.Size);
  Content.Assign(Criteria.Content);
  if Content.PhraseLen > 0 then
    Attribute.Attributes := Attribute.Attributes - [ffDirectory];
end;

destructor TTargetSearch.Destroy;
begin
  TargetFolders.Free;
  Attribute.Free;
  AttributeEx.Free;
  TimeStamp.Free;
  Size.Free;
  Content.Free;
  inherited Destroy;
end;

procedure TTargetSearch.PrepareTargetFolders(FileCriteria: TFileCriteria);

  function CreateItemsList(const ItemsText: String): TStringList;
  var
    Item: String;
    StartIndex: Integer;
    DelimiterPos: Integer;
    ItemsTextLen: Integer;
  begin
    Result := TStringList.Create;
    ItemsTextLen := Length(ItemsText);
    StartIndex := 1;
    repeat
      DelimiterPos := StartIndex;
      while (DelimiterPos <= ItemsTextLen) and (ItemsText[DelimiterPos] <> Delimiter) do
        Inc(DelimiterPos);
      if StartIndex <> DelimiterPos then
      begin
        Item := Trim(Copy(ItemsText, StartIndex, DelimiterPos - StartIndex));
        if (Item <> '') and (Result.IndexOf(Item) < 0) then
          Result.Add(Item);
      end;
      StartIndex := DelimiterPos + 1;
    until StartIndex > ItemsTextLen;
  end;

  function CheckSubfolders(var Folder: String): Boolean;
  begin
    Result := FileCriteria.Subfolders;
    if Folder <> '' then
    begin
      case Folder[1] of
        IncSubfolders:
        begin
          Result := True;
          Delete(Folder, 1, 1);
        end;
        ExcSubfolders:
        begin
          Result := False;
          Delete(Folder, 1, 1);
        end;
      end;
    end;
  end;

var
  I: Integer;
  Item: String;
  FileMask: String;
  FileList: TStringList;
  FolderList: TStringList;
  ThisFolder: TTargetFolder;
  Subfolders: Boolean;
begin
  TargetFolders.ExcludedFiles.Assign(FileCriteria.Excluded);
  // Processes Included property
  for I := 0 to FileCriteria.Included.Count - 1 do
  begin
    Item := FileCriteria.Included[I];
    Subfolders := CheckSubfolders(Item);
    ThisFolder := TargetFolders.AddFolder(ExtractFilePath(Item));
    FileMask := ExtractFileName(Item);
    if FileMask <> '' then
      ThisFolder.FileMasks.Add(FileMask)
    else
      ThisFolder.FileMasks.Add('*.*');
    ThisFolder.Subfolders := Subfolders;
    ThisFolder.MinLevel := FileCriteria.MinLevel;
    ThisFolder.MaxLevel := FileCriteria.MaxLevel;
  end;
  // Processes FileName and Location properties
  FileList := CreateItemsList(FileCriteria.FileName);
  try
    if FileList.Count = 0 then
      FileList.Add('*.*');
    FolderList := CreateItemsList(FileCriteria.Location);
    try
      for I := 0 to FolderList.Count - 1 do
      begin
        Item := FolderList[I];
        Subfolders := CheckSubfolders(Item);
        ThisFolder := TargetFolders.AddFolder(Item);
        ThisFolder.FileMasks.AddStrings(FileList);
        ThisFolder.Subfolders := Subfolders;
        ThisFolder.MinLevel := FileCriteria.MinLevel;
        ThisFolder.MaxLevel := FileCriteria.MaxLevel;
      end;
    finally
      FolderList.Free;
    end;
  finally
    FileList.Free;
  end;
end;

function TTargetSearch.Matches(const Folder: String;
  const SR: TSearchRec): Boolean;
var
  FileSize: TFileSize;
begin
  with SR.FindData do
  begin
    {$IFDEF COMPILER4_UP}
    FileSize := (Int64(nFileSizeHigh) * MAXDWORD) + nFileSizeLow;
    {$ELSE}
    FileSize := SR.Size;
    {$ENDIF}
    Result := Size.Matches(FileSize)
      and Attribute.Matches(SR.Attr)
      and AttributeEx.Matches(dwFileAttributes)
      and TimeStamp.Matches(ftCreationTime, ftLastWriteTime, ftLastAccessTime)
      and not TargetFolders.IsExcluded(Folder, SR.Name)
      and Content.Matches(Folder + SR.Name);
  end;
end;

{ TSearchThread }

type
  TSearchThread = class(TThread)
  private
    Owner: TFindFile;
  protected
    constructor Create(AOwner: TFindFile);
    procedure Execute; override;
  end;

constructor TSearchThread.Create(AOwner: TFindFile);
begin
  inherited Create(True);
  Owner := AOwner;
  Priority := Owner.ThreadPriority;
  Resume;
end;

procedure TSearchThread.Execute;
begin
  try
    try
      Owner.SearchForFiles;
    except
      {$IFDEF COMPILER6_UP}
      on E: Exception do ApplicationShowException(E);
      {$ENDIF}
    end;
  finally
    PostMessage(Owner.ThreadWnd, FF_THREADTERMINATED, 0, 0);
  end;
end;

{ TFindFile }

constructor TFindFile.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  InitializeCriticalSection(CS);
  fThreadWnd := AllocateHWnd(ThreadWndCallback);
  fCriteria := TSearchCriteria.Create;
  fThreaded := False;
  fThreadPriority := tpNormal;
  fAborted := False;
  fBusy := False;
end;

destructor TFindFile.Destroy;
begin
  if Busy then Abort;
  fCriteria.Free;
  DeallocateHWnd(fThreadWnd);
  DeleteCriticalSection(CS);
  inherited Destroy;
end;

procedure TFindFile.Abort;
var
  Msg: TMSG;
begin
  if Busy and not Aborted then
  begin
    fAborted := True;
    while not TryEnterCriticalSection(CS) do
    begin
      if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
    end;
    DoSearchAbort;
    LeaveCriticalSection(CS);
  end;
end;

procedure TFindFile.DoFileMatch(const Folder: String;
  const FileInfo: TSearchRec);
begin
  if not Aborted and Assigned(fOnFileMatch) then
  begin
    EnterCriticalSection(CS);
    try
      fOnFileMatch(Self, Folder, FileInfo);
    finally
      LeaveCriticalSection(CS);
    end;
  end;
end;

function TFindFile.DoFolderChange(const Folder: String): TFolderIgnore;
begin
  Result := fiNone;
  if not Aborted and Assigned(fOnFolderChange) then
  begin
    EnterCriticalSection(CS);
    try
      fOnFolderChange(Self, Folder, Result);
    finally
      LeaveCriticalSection(CS);
    end;
  end;
end;

procedure TFindFile.DoSearchBegin;
begin
  if Assigned(fOnSearchBegin) and not (csDestroying in ComponentState) then
    fOnSearchBegin(Self);
end;

procedure TFindFile.DoSearchFinish;
begin
  if Assigned(fOnSearchFinish) and not (csDestroying in ComponentState) then
    fOnSearchFinish(Self);
end;

procedure TFindFile.DoSearchAbort;
begin
  if Assigned(fOnSearchAbort) and not (csDestroying in ComponentState) then
    fOnSearchAbort(Self);
end;

function TFindFile.IsAcceptable(const Folder: String; const SR: TSearchRec): Boolean;
begin
  Result := not Aborted and TargetSearch.Matches(Folder, SR);
end;

procedure TFindFile.InitializeSearch;
begin
  fBusy := True;
  fAborted := False;
  TargetSearch := TTargetSearch.Create(Criteria);
  DoSearchBegin;
end;

procedure TFindFile.FinalizeSearch;
begin
  DoSearchFinish;
  TargetSearch.Free;
  TargetSearch := nil;
  fBusy := False;
end;

procedure TFindFile.SearchForFiles;
var
  Index: Integer;
begin
  Index := TargetSearch.TargetFolders.Count;
  while not Aborted and (Index > 0) do
  begin
    Dec(Index);
    fCurrentLevel := 0;
    ActiveTargetFolder := TargetSearch.TargetFolders[Index];
    SearchIn(ActiveTargetFolder.Folder);
  end;
end;

procedure TFindFile.SearchIn(const Path: String);
var
  SR: TSearchRec;
  MaskIndex: Integer;
  Flag: TFolderIgnore;
begin
  if Aborted then Exit;
  Inc(fCurrentLevel);
  try
    Flag := DoFolderChange(Path);
    with ActiveTargetFolder do
    begin
      // Searches in the current folder for all file masks
      if (Flag in [fiNone, fiJustSubfolders]) and (CurrentLevel >= MinLevel) then
      begin
        MaskIndex := FileMasks.Count;
        while (MaskIndex > 0) and not Aborted do
        begin
          Dec(MaskIndex);
          if not Aborted and (FindFirst(Path + FileMasks[MaskIndex], ValidFileAttr, SR) = 0) then
            try
              repeat
                if (not LongBool(SR.Attr and faDirectory) or
                   ((SR.Name <> '.') and (SR.Name <> '..'))) and
                   IsAcceptable(Path, SR)
                then
                  DoFileMatch(Path, SR);
              until Aborted or (FindNext(SR) <> 0);
            finally
              FindClose(SR);
            end;
        end;
      end;
      // Searches in subfolders
      if Subfolders and (Flag in [fiNone, fiJustThis]) and
        ((MaxLevel = 0) or (CurrentLevel < MaxLevel)) then
      begin
        if not Aborted and (FindFirst(Path + '*.*', ValidFileAttr, SR) = 0) then
          try
            repeat
              if LongBool(SR.Attr and faDirectory) and
                (SR.Name <> '.') and (SR.Name <> '..')
              then
                SearchIn(Path + SR.Name + '\');
            until Aborted or (FindNext(SR) <> 0);
          finally
            FindClose(SR);
          end;
      end;
    end;
  finally
    Dec(fCurrentLevel);
  end;
end;

procedure TFindFile.Execute;
begin
  if not Busy then
  begin
    if not Threaded then
    begin
      InitializeSearch;
      try
        SearchForFiles;
      finally
        FinalizeSearch;
      end;
    end
    else
    begin
      InitializeSearch;
      try
       SearchThread := TSearchThread.Create(Self);
      except
        FinalizeSearch;
        raise;
      end;
    end;
  end;
end;

procedure TFindFile.SetCriteria(Value: TSearchCriteria);
begin
  Criteria.Assign(Value);
end;

procedure TFindFile.ThreadWndCallback(var Msg: TMessage);
begin
  case Msg.Msg of
    FF_THREADTERMINATED:
    begin
      SearchThread.Free;
      SearchThread := nil;
      FinalizeSearch;
    end;
  else
    with Msg do Result := DefWindowProc(ThreadWnd, Msg, WParam, LParam);
  end;
end;

procedure Register;
begin
  RegisterComponents('Delphi Area', [TFindFile]);
end;

initialization
  InitFastContentSearch;
end.