findfile.pas

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

//------------------------------------------------------------------------------
//
//   TFindFile v3.53
//   by Kambiz R. Khojasteh
//
//
//   [e-mail]
//   http://www.delphiarea.com
//
//
//   Special thanks to:
//
//     :: Frederik Decoster <[e-mail]> for fixing folder look up bug.
//     :: Nitin Chandra <[e-mail]> for the idea of dir level criterion.
//     :: Roman Olexa <[e-mail]> for adding UNC path support.
//     :: Sohnel-Software - SUPPORT <[e-mail]> for fixing a bug.
//     :: Florian Schick for fixing the big file size issue and adding NT file attributes.
//
//------------------------------------------------------------------------------

{$I DELPHIAREA.INC}

{$IFDEF COMPILER6_UP}
  {$WARN UNIT_PLATFORM OFF}
  {$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}

unit FindFile;

interface

uses
  Windows, Messages, Classes, SysUtils;

const
  FILE_ATTRIBUTE_SPARSE_FILE        = $00000200;
  {$IFDEF COMPILER4_UP}
  {$EXTERNALSYM FILE_ATTRIBUTE_SPARSE_FILE}
  {$ENDIF}
  FILE_ATTRIBUTE_REPARSE_POINT      = $00000400;
  {$IFDEF COMPILER4_UP}
  {$EXTERNALSYM FILE_ATTRIBUTE_REPARSE_POINT}
  {$ENDIF}
  FILE_ATTRIBUTE_ENCRYPTED          = $00004000;
  {$IFDEF COMPILER4_UP}
  {$EXTERNALSYM FILE_ATTRIBUTE_ENCRYPTED}
  {$ENDIF}

type

  TFileCriteria = class(TPersistent)
  private
    fFilename: String;
    fLocation: String;
    fIncluded: TStringList;
    fExcluded: TStringList;
    fSubfolders: Boolean;
    fMinLevel: Word;
    fMaxLevel: Word;
    procedure SetIncluded(Value: TStringList);
    procedure SetExcluded(Value: TStringList);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property FileName: String read fFilename write fFilename;
    property Location: String read fLocation write fLocation;
    property Included: TStringList read fIncluded write SetIncluded;
    property Excluded: TStringList read fExcluded write SetExcluded;
    property Subfolders: Boolean read fSubfolders write fSubfolders default True;
    property MinLevel: Word read fMinLevel write fMinLevel default 0;
    property MaxLevel: Word read fMaxLevel write fMaxLevel default 0;
  end;

  TFileAttributes = set of (ffArchive, ffReadonly, ffHidden, ffSystem, ffDirectory);

  TAttributeCriteria = class(TPersistent)
  private
     fFlags: Integer;
     fExactMatch: Boolean;
     function GetAttributes: TFileAttributes;
     procedure SetAttributes(Value: TFileAttributes);
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    property Flags: Integer read fFlags write fFlags;
    function Matches(Attr: Integer): Boolean;
  published
    property Attributes: TFileAttributes read GetAttributes write SetAttributes
      default [ffArchive, ffReadonly, ffHidden, ffSystem];
    property ExactMatch: Boolean read fExactMatch write fExactMatch default False;
  end;

  TFileAttributeStatus = (fsIgnore, fsSet, fsUnset);

  TAttributeCriteriaEx = class(TPersistent)
  private
    fSetFlags: DWORD;
    fUnsetFlags: DWORD;
    function GetAttribute(Index: Integer): TFileAttributeStatus;
    procedure SetAttribute(Index: Integer; Value: TFileAttributeStatus);
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    function Matches(Attr: DWORD): Boolean;
  published
    property Archive: TFileAttributeStatus index 1 read GetAttribute write SetAttribute default fsIgnore;
    property Readonly: TFileAttributeStatus index 2 read GetAttribute write SetAttribute default fsIgnore;
    property Hidden: TFileAttributeStatus index 3 read GetAttribute write SetAttribute default fsIgnore;
    property System: TFileAttributeStatus index 4 read GetAttribute write SetAttribute default fsIgnore;
    property Directory: TFileAttributeStatus index 5 read GetAttribute write SetAttribute default fsIgnore;
    property Compressed: TFileAttributeStatus index 6 read GetAttribute write SetAttribute default fsIgnore;
    property Encrypted: TFileAttributeStatus index 7 read GetAttribute write SetAttribute default fsIgnore;
    property Offline: TFileAttributeStatus index 8 read GetAttribute write SetAttribute default fsIgnore;
    property ReparsePoint: TFileAttributeStatus index 9 read GetAttribute write SetAttribute default fsIgnore;
    property SparseFile: TFileAttributeStatus index 10 read GetAttribute write SetAttribute default fsIgnore;
    property Temporary: TFileAttributeStatus index 11 read GetAttribute write SetAttribute default fsIgnore;
  end;

  TDateTimeCriteria = class(TPersistent)
  private
     fCreatedBefore: TDateTime;
     fCreatedAfter: TDateTime;
     fModifiedBefore: TDateTime;
     fModifiedAfter: TDateTime;
     fAccessedBefore: TDateTime;
     fAccessedAfter: TDateTime;
  public
    procedure Assign(Source: TPersistent); override;
    function Matches(const Created, Modified, Accessed: TFileTime): Boolean;
  published
    property CreatedBefore: TDateTime read fCreatedBefore write fCreatedBefore;
    property CreatedAfter: TDateTime read fCreatedAfter write fCreatedAfter;
    property ModifiedBefore: TDateTime read fModifiedBefore write fModifiedBefore;
    property ModifiedAfter: TDateTime read fModifiedAfter write fModifiedAfter;
    property AccessedBefore: TDateTime read fAccessedBefore write fAccessedBefore;
    property AccessedAfter: TDateTime read fAccessedAfter write fAccessedAfter;
  end;

  TFileSize = {$IFDEF COMPILER4_UP} Int64 {$ELSE} DWORD {$ENDIF};

  TSizeCriteria = class(TPersistent)
  private
    fMin: TFileSize;
    fMax: TFileSize;
  public
    procedure Assign(Source: TPersistent); override;
    function Matches(const Size: TFileSize): Boolean;
  published
    property Min: TFileSize read fMin write fMin default 0;
    property Max: TFileSize read fMax write fMax default 0;
  end;

  PCharMap = ^TCharMap;
  TCharMap = array[Char] of Char;

  TContentCriteria = class(TPersistent)
  private
    fPhrase: String;
    fPhraseLen: Integer;
    fIgnoreCase: Boolean;
    fWholeWord: Boolean;
    fTargetPhrase: String;
    fCharMap: PCharMap;
    procedure SetPhrase(const Value: String);
    procedure SetIgnoreCase(Value: Boolean);
  protected
    property TargetPhrase: String read fTargetPhrase;
    property CharMap: PCharMap read fCharMap;
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    property PhraseLen: Integer read fPhraseLen;
    function Matches(const FileName: String): Boolean;
  published
    property Phrase: String read fPhrase write SetPhrase;
    property IgnoreCase: Boolean read fIgnoreCase write SetIgnoreCase default True;
    property WholeWord: Boolean read fWholeWord write fWholeWord default False;
  end;

  TSearchCriteria = class(TPersistent)
  private
    fFiles: TFileCriteria;
    fAttribute: TAttributeCriteria;
    fAttributeEx: TAttributeCriteriaEx;
    fTimeStamp: TDateTimeCriteria;
    fSize: TSizeCriteria;
    fContent: TContentCriteria;
    procedure SetFiles(Value: TFileCriteria);
    procedure SetAttribute(Value: TAttributeCriteria);
    procedure SetAttributeEx(Value: TAttributeCriteriaEx);
    procedure SetTimeStamp(Value: TDateTimeCriteria);
    procedure SetSize(Value: TSizeCriteria);
    procedure SetContent(Value: TContentCriteria);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property Files: TFileCriteria read fFiles write SetFiles;
    property Attribute: TAttributeCriteria read fAttribute write SetAttribute;
    property AttributeEx: TAttributeCriteriaEx read fAttributeEx write SetAttributeEx;
    property TimeStamp: TDateTimeCriteria read fTimeStamp write SetTimeStamp;
    property Size: TSizeCriteria read fSize write SetSize;
    property Content: TContentCriteria read fContent write SetContent;
  end;

  TTargetFolder = class(TObject)
  private
    fFolder: String;
    fSubfolders: Boolean;
    fFileMasks: TStringList;
    fMinLevel: Word;
    fMaxLevel: Word;
  public
    constructor Create;
    destructor Destroy; override;
    property Folder: String read fFolder write fFolder;
    property Subfolders: Boolean read fSubfolders write fSubfolders;
    property FileMasks: TStringList read fFileMasks;
    property MinLevel: Word read fMinLevel write fMinLevel;
    property MaxLevel: Word read fMaxLevel write fMaxLevel;
  end;

  TTargetFolderList = class(TList)
  private
    fExcludedFiles: TStringList;
    function GetItems(Index: Integer): TTargetFolder;
  public
    constructor Create;
    destructor Destroy; override;
    function IndexOfFolder(const Folder: String): Integer;
    function AddFolder(const Folder: String): TTargetFolder;
    function IsExcluded(const Folder, FileName: String): Boolean;
    property Items[Index: Integer]: TTargetFolder read GetItems; default;
    property ExcludedFiles: TStringList read fExcludedFiles;
  end;

  // TTargetSearch holds all running search parameters. This allows us to change
  // the component's properties without affecting the running search, which is
  // very important for a threaded search.
  TTargetSearch = class(TObject)
  protected
     TargetFolders: TTargetFolderList;
     Attribute: TAttributeCriteria;
     AttributeEx: TAttributeCriteriaEx;
     TimeStamp: TDateTimeCriteria;
     Size: TSizeCriteria;
     Content: TContentCriteria;
     procedure PrepareTargetFolders(FileCriteria: TFileCriteria);
  public
    constructor Create(Criteria: TSearchCriteria);
    destructor Destroy; override;
    function Matches(const Folder: String; const SR: TSearchRec): Boolean;
  end;

  TFolderIgnore = (fiNone, fiJustThis, fiJustSubfolders, fiThisAndSubfolders);

  TFileMatchEvent = procedure (Sender: TObject; const Folder: String;
    const FileInfo: TSearchRec) of object;

  TFolderChangeEvent = procedure (Sender: TObject; const Folder: String;
    var IgnoreFolder: TFolderIgnore) of object;

  TFindFile = class(TComponent)
  private
    fCriteria: TSearchCriteria;
    fThreaded: Boolean;
    fThreadPriority: TThreadPriority;
    fAborted: Boolean;
    fBusy: Boolean;
    fCurrentLevel: Word;
    fOnFileMatch: TFileMatchEvent;
    fOnFolderChange: TFolderChangeEvent;
    fOnSearchBegin: TNotifyEvent;
    fOnSearchFinish: TNotifyEvent;
    fOnSearchAbort: TNotifyEvent;
    fThreadWnd: HWND;
    TargetSearch: TTargetSearch;
    ActiveTargetFolder: TTargetFolder;
    SearchThread: TThread;
    CS: TRTLCriticalSection;
    procedure SetCriteria(Value: TSearchCriteria);
    procedure InitializeSearch;
    procedure FinalizeSearch;
    procedure SearchForFiles;
    procedure SearchIn(const Path: String);
    procedure ThreadWndCallback(var Msg: TMessage);
  protected
    procedure DoSearchBegin; virtual;
    procedure DoSearchFinish; virtual;
    procedure DoSearchAbort; virtual;
    function DoFolderChange(const Folder: String): TFolderIgnore; virtual;
    procedure DoFileMatch(const Folder: String; const FileInfo: TSearchRec); virtual;
    function IsAcceptable(const Folder: String; const SR: TSearchRec): Boolean; virtual;
    property ThreadWnd: HWND read fThreadWnd;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute;
    procedure Abort;
    property Busy: Boolean read fBusy;
    property Aborted: Boolean read fAborted;
    property CurrentLevel: Word read fCurrentLevel;
  published
    property Criteria: TSearchCriteria read fCriteria write SetCriteria;
    property Threaded: Boolean read fThreaded write fThreaded default False;
    property ThreadPriority: TThreadPriority read fThreadPriority write fThreadPriority default tpNormal;
    property OnFileMatch: TFileMatchEvent read fOnFileMatch write fOnFileMatch;
    property OnFolderChange: TFolderChangeEvent read fOnFolderChange write fOnFolderChange;
    property OnSearchBegin: TNotifyEvent read fOnSearchBegin write fOnSearchBegin;
    property OnSearchFinish: TNotifyEvent read fOnSearchFinish write fOnSearchFinish;
    property OnSearchAbort: TNotifyEvent read fOnSearchAbort write fOnSearchAbort;
  end;

procedure Register;

function AddTrailingBackslash(const Path: String): String;
function RemoveTrailingBackslash(const Path: String): String;
function FileTimeToDateTime(const FileTime: TFileTime): TDateTime;
function IsDateBetween(const aDate, Before, After: TDateTime): Boolean;
function FileContains(const FileName: String; const Phrase: String;
  IgnoreCase, WholeWord: Boolean): Boolean;

implementation

uses
  {$IFNDEF COMPILER6_UP} Forms, {$ENDIF}
  FileCtrl;

const
  Delimiter     = ';';
  IncSubfolders = '>';
  ExcSubfolders = '<';
  ValidFileAttr = faAnyFile and not faVolumeID;

const
  FF_THREADTERMINATED = WM_USER + 1;

const
  FileAttributesEx: array[1..11] of DWORD = (
    FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_READONLY,
    FILE_ATTRIBUTE_HIDDEN, FILE_ATTRIBUTE_SYSTEM,
    FILE_ATTRIBUTE_DIRECTORY, FILE_ATTRIBUTE_COMPRESSED,
    FILE_ATTRIBUTE_ENCRYPTED, FILE_ATTRIBUTE_OFFLINE,
    FILE_ATTRIBUTE_REPARSE_POINT, FILE_ATTRIBUTE_SPARSE_FILE,
    FILE_ATTRIBUTE_TEMPORARY);

{ Character Map for faster case-insensitive search }

var
  NormalCharMap: TCharMap;
  LowerCharMap: TCharMap;
  WordDelimiters: set of Char;

procedure InitFastContentSearch;
var
  C: Char;
begin
  WordDelimiters := [];
  for C := Low(TCharMap) to High(TCharMap) do
  begin
    NormalCharMap[C] := C;
    LowerCharMap[C] := C;
    if not IsCharAlphaNumeric(C) then
      Include(WordDelimiters, C);
  end;
  AnsiLowerBuff(PChar(@LowerCharMap), SizeOf(LowerCharMap));
end;

{ Helper Functions }

function AddTrailingBackslash(const Path: String): String;
var
  PathLen: Integer;
begin
  PathLen := Length(Path);
  if (PathLen > 0) and not (Path[PathLen] in ['\', ':']) then
    Result := Path + '\'
  else
    Result := Path;
end;

function RemoveTrailingBackslash(const Path: String): String;
var
  PathLen: Integer;
begin
  PathLen := Length(Path);
  if (PathLen > 1) and (Path[PathLen] = '\') and (Path[PathLen-1] <> ':') then
    Result := Copy(Path, 1, PathLen - 1)
  else
    Result := Path;
end;

function FileTimeToDateTime(const FileTime: TFileTime): TDateTime;
var
  LocalFileTime: TFileTime;
  SystemTime: TSystemTime;
begin
  FileTimeToLocalFileTime(FileTime, LocalFileTime);
  FileTimeToSystemTime(LocalFileTime, SystemTime);
  Result := SystemTimeToDateTime(SystemTime);
end;

function IsDateBetween(const aDate, Before, After: TDateTime): Boolean;
begin
  Result := True;
  if Before <> 0 then
    if Frac(Before) = 0 then      { Checks date only }
      Result := Result and (Int(aDate) <= Before)
    else if Int(Before) = 0 then  { Checks time only }
      Result := Result and (Frac(aDate) <= Before)
    else                          { Checks date and time }
      Result := Result and (aDate <= Before);
  if After <> 0 then
    if Frac(After) = 0 then       { Checks date only }
      Result := Result and (Int(aDate) >= After)
    else if Int(After) = 0 then   { Checks time only }
      Result := Result and (Frac(aDate) >= After)
    else                          { Checks date and time }
      Result := Result and (aDate >= After);
end;

function FileContainsPhrase(const FileName: String; const Phrase: PChar;
  PhraseLen: Integer; const CharMap: TCharMap; WholeWord: Boolean): Boolean;
const
  MaxBufferSize = $F000; // Must be larger than PhraseLen
var
  Stream: TFileStream;
  DataSize, BufferSize: Integer;
  Buffer, BufferPtr: PChar;
  SearchCount, MatchCount: Integer;
  PrvChar: Char;
begin
  Result := False;
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
  try
    DataSize := Stream.Size;
    if DataSize >= PhraseLen then
    begin
      if DataSize > MaxBufferSize then
        if PhraseLen <= MaxBufferSize then
          BufferSize := MaxBufferSize
        else
          BufferSize := PhraseLen + 1
      else
        BufferSize := DataSize;
      GetMem(Buffer, BufferSize);
      try
        PrvChar := #0;
        SearchCount := Stream.Read(Buffer^, BufferSize);
        while SearchCount > 0 do
        begin
          BufferPtr := Buffer;
          while SearchCount > 0 do
          begin
            if (CharMap[BufferPtr^] = Phrase^) and (not WholeWord or (PrvChar in WordDelimiters)) then
            begin
              MatchCount := 0;
              repeat
                Inc(MatchCount);
                if MatchCount = PhraseLen then
                begin
                  if not WholeWord or ((MatchCount < SearchCount) and (BufferPtr[MatchCount] in WordDelimiters)) then
                  begin
                    Result := True;
                    Exit;
                  end
                  else if MatchCount = SearchCount then
                    Result := True
                  else
                    Break;
                end;
                if MatchCount = SearchCount then
                begin
                  Move(BufferPtr^, Buffer^, MatchCount);
                  BufferPtr := Buffer;
                  SearchCount := Stream.Read(Buffer[MatchCount], BufferSize - MatchCount) + MatchCount;
                  if SearchCount < PhraseLen then
                    Exit
                  else if Result then
                  begin
                    if (SearchCount = MatchCount) or (BufferPtr[MatchCount] in WordDelimiters) then
                      Exit
                    else
                    begin
                      Result := False;
                      Break;
                    end;
                  end;
                end;
              until CharMap[BufferPtr[MatchCount]] <> Phrase[MatchCount];