//////////////////////////////////////////////////////////
//
// Name        : TlplFindFile
// Author      : Christian Aaangel (C.Aaangel@Mailexcite.com)
// Group       : File Management
// Purpose     : Search for file(s)
// Version     : 1.04
// Last update : May 20th 2004
//
//////////////////////////////////////////////////////////
//
// What's new:
// 1.00 - initial Release
// 1.01 - Fixed Call to complete when running without
//        Subdirectories
// 1.02 - Added Include Property
// 1.03 - Added Size Option
//        Added Date Option
//        Removed Attr System (Didn't Work Anyway)
// 1.04 - Added Folder Search depth
//
//////////////////////////////////////////////////////////
unit lplFindFile;

{$WARN UNIT_PLATFORM OFF}
{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  FileCtrl;

type
  TOfDrives = Record
   Floppy: Boolean;
   Fixed: Boolean;
   NetWork: Boolean;
   CD: Boolean;
   Ram: Boolean;
  End;
  TSizeSearchMode = (ssmDontCare, ssmLarger, ssmSmaller, ssmEqual);
  TDateSearchMode = (dsmDontCare, dsmNewer, dsmOlder, dsmBetween);
  TFileAttr = set of (ReadOnly, Hidden, SysFile, Archive);
  TFileFound = Procedure(Sender: TObject; Folder: String; FileInfo: TSearchRec) of Object;
  TNewFolder = Procedure(Sender: TObject; Folder: String) of Object;
  TComplete = Procedure(Sender: TObject) of Object;
  TlplFindFile = class(TComponent)
  private
//   fAttr: Integer;
   RunSingle: Boolean;
   RunningThreads: Integer;
   fSize: Int64;
   fMask: String;
   fPath: String;
   fSubs: Boolean;
   fNewFolder: TNewFolder;
   fFileFound: TFileFound;
   fComplete: TComplete;
   fInclude: String;
   fDateEarly, fDateLate: String;
   fDateOption: TDateSearchMode;
   fSizeOption: TSizeSearchMode;
   fSubsLevel: Integer;
   fCurrentSubCount: Integer;
   Function PathToOk(aPath: String): String;
   Procedure SetMask(Value: String);
   Procedure SetPath(Value: String);
   Procedure SetSubs(Value: Boolean);
   Procedure SetInclude(Value: String);
   Procedure SearchFiles(Path: String; Mask: String);
   Procedure SearchDirectory(Path: String; Mask: String; Attr: Integer);
   Function TypeofDrive(Drive: Char): String;
   Function BuildDriveList(ofFloppy, ofFixed, ofCD, ofNetwork, ofRam: Boolean): String;
   Procedure SearchDrives_Private(DriveList: String);
   Function CountFilt(From: String; Seperator: Char = ';'): Integer;
   Function GetFilt(From: String; Number: Integer; Seperator: Char = ';'): String;
   function encodeAttr : integer;
   Procedure Search_Private;
   procedure SetEarlyDate(const Value: String);
   procedure SetLateDate(const Value: String);
   procedure SetDateOption(const Value: TDateSearchMode);
   Function CheckSizeFile(FileSize: Int64): Boolean;
   Function CheckDateFile(FileName: TFileName): Boolean;
   procedure SetSize(const Value: Int64);
   procedure SetSizeOption(const Value: TSizeSearchMode);
  public
   Constructor Create(aOwner: TComponent); Override;
   Destructor Destroy; Override;
   Procedure SearchDriveList(Floppy, Fixed, Cd, Network, Ram: Boolean); overload;
   Procedure SearchDriveList(DriveList: String); overload;
  published
   Property DateOption: TDateSearchMode read fDateOption Write SetDateOption;
   Property Date1: String read fDateEarly Write SetEarlyDate;
   Property Date2: String read fDateLate Write SetLateDate;
   Property Include: String read fInclude Write SetInclude;
   Property Mask: String read fMask Write SetMask;
   Property Path: String read fPath Write SetPath;
   Property Size: Int64 read fSize Write SetSize;
   Property SizeOption: TSizeSearchMode read fSizeOption Write SetSizeOption;
   Property Subs: Boolean Read fSubs Write SetSubs;
   Property SearchDepth: Integer read fSubsLevel write fSubsLevel;
   Property OnFound: TFileFound read fFileFound Write fFileFound;
   Property OnNewFolder: TNewFolder read fNewFolder Write fNewFolder;
   Property OnComplete: TComplete Read fComplete Write fComplete;
   Procedure Search;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('LPL Tools', [TlplFindFile]);
end;

Constructor TlplFindFile.Create(AOwner: TComponent);
Begin
 Inherited Create(aOwner);
End;

Destructor TlplFindFile.Destroy;
Begin
 Inherited Destroy;
End;

Procedure TlplFindFile.SetInclude(Value: String);
Begin
 If Value <> fInclude Then fInclude := Value;
End;

Procedure TlplFindFile.SetMask(Value: String);
Begin
 If fMask <> Value Then fMask := Value;
End;

Procedure TlplFindFile.SetPath(Value: String);
Begin
 If fPath <> Value Then fPath := Value;;
End;

Procedure TlplFindFile.SetSubs(Value: Boolean);
Begin
 If fSubs <> Value Then fSubs := Value;
End;

Function TlplFindFile.CountFilt(From: String; Seperator: Char = ';'): Integer;
var
 Res, IC: Integer;
Begin
 Res := 0;
 If Length(From) > 0 Then begin
  Res := 1;
  For IC := 1 to length(From) do begin
   If From[IC] = Seperator Then Inc(Res);
  End;
 End;
 Result := Res;
End;

Function TlplFindFile.GetFilt(From: String; Number: Integer; Seperator: Char = ';'): String;
Var
 LastRecorded, CStart, CSlut, ATF, IC: Integer;
 Res: String;
Begin
 Res := '';
 If Number > CountFilt(From, Seperator) Then Begin
  Result := Res;
  Exit;
 End;
 If Length(From) > 0 Then begin
  If (From[1] = Seperator) And (Number = 1) Then Begin
   Result := Res;
   Exit;
  End;
  CStart := 0;
  CSlut := 0;
  ATF := 1;
  LastRecorded := 0;
  If Number = 1 Then CStart := 1;
  For IC := 1 to length(From) do begin
   LastRecorded := IC;
   If From[IC] = Seperator Then begin
    Inc(ATF);
    If ATF = Number Then CStart := IC + 1;
    If ATF = Number + 1 Then CSlut := IC - 1;
   End;
  End;
  If (CStart <> 0) And (CSlut = 0) Then CSlut := LastRecorded;
  Res := Copy(From, CStart, CSlut - CStart + 1);
 End;
 Result := Res;
End;

Function TlplFindFile.TypeofDrive(Drive: Char): String;
Var
 S: String;
 DriveType : TDrivetype;
begin
  DriveType := TDriveType(GetDriveType(PChar(Drive+':\')));
  If Drivetype = dtUnknown Then S := 'Unknown';
  If Drivetype = dtNoDrive Then S := 'No drive';
  If Drivetype = dtFloppy Then S := 'Floppy';
  If Drivetype = dtFixed Then S := 'Fixed';
  If Drivetype = dtNetwork Then S := 'Network';
  If Drivetype = dtCDROM Then S := 'CDROM';
  If Drivetype = dtRAM Then S := 'Ram';
  Result := S;
end;

Function TlplFindFile.BuildDriveList(ofFloppy, ofFixed, ofCD, ofNetwork, ofRam: Boolean): String;
Var
 I, First, Last: Integer;
 Res: String;
Begin
 If ofFloppy Then First := ord('A')
  else First := ord('C');
 Last := ord('Z');
 For I := First to Last do begin
  If (Typeofdrive(Chr(I)) = 'Floppy') and (ofFloppy) Then Res := Res + Chr(I) + ';';
  If (Typeofdrive(Chr(I)) = 'Fixed') and (ofFixed) Then Res := Res + Chr(I) + ';';
  If (Typeofdrive(Chr(I)) = 'CDROM') and (ofCD) Then Res := Res + Chr(I) + ';';
  If (Typeofdrive(Chr(I)) = 'Network') and (ofNetwork) Then Res := Res + Chr(I) + ';';
  If (Typeofdrive(Chr(I)) = 'Ram') and (ofRam) Then Res := Res + Chr(I) + ';';
 End;
 If Res[Length(Res)] = ';' Then Res := Copy(Res, 1, length(Res) - 1); // Remove trailing ;
 Result := Res;
End;

Function TlplFindFile.CheckSizeFile(FileSize: Int64): Boolean;
Begin
 Result := False;
 If fSizeOption = ssmDontCare Then Begin
  Result := True;
  Exit;
 End;
 Case fSizeOption of
  ssmEqual: Begin
             If fSize = FileSize Then Result := True
              else Result := False;
            End;
  ssmLarger: Begin
             If fSize <= FileSize Then Result := True
              else Result := False;
            End;
  ssmSmaller: Begin
             If fSize >= FileSize Then Result := True
              else Result := False;
            End;
 End;
End;

Function TlplFindFile.CheckDateFile(FileName: TFileName): Boolean;
Var
 DateEarly, DateLate, Date: TDate;
Begin
 Result := False;
 If fDateOption = dsmDontCare Then Begin
  result := true;
  Exit;
 End;
 Date := FileDateToDateTime(FileAge(Filename));
 DateEarly := StrToDate(fDateEarly);
 DateLate := StrToDate(fDateLate);
 Case fDateOption of
  dsmDontCare: Result := True;
  dsmOlder: Begin // Ældre
            If DateEarly >= Date Then Result := True
             else Result := False;
           End;
  dsmNewer: Begin // nyere
            If DateEarly <= Date Then Result := True
             else Result := False;
           End;
  dsmBetween: Begin // I mellem
              If (Date >= DateEarly) And (Date <= DateLate) Then Result := True
               else Result := False;
             End;
 End;
End;

Procedure TlplFindFile.SearchFiles(Path: String; Mask: String);
Var
 SearchRec: TSearchRec;
 Res, I: Integer;
 S1, FName: String;
 UseInclude: Boolean;
Begin
 UseInclude := False;
 If fInclude <> '' Then begin
  Mask := '*.*';
  UseInclude := True;
 End;
 Res := FindFirst(PathToOk(Path) + Mask, encodeAttr, SearchRec);
 If Res = 0 Then Begin
  Repeat
   Application.ProcessMessages;
   FName := PathToOk(Path) + SearchRec.Name;
   If (SearchRec.Name = '.') or (SearchRec.Name = '..') Then Begin
    FName := '';
   End
    else
   Begin
    If UseInclude then Begin
     S1 := ExtractFileext(SearchRec.Name);
     If S1 <> '' Then bEgin
      If S1[1] = '.' Then S1 := Copy(S1, 2, length(s1));
     End;
     For I := 1 to countFilt(fInclude, ';') do begin
      If Uppercase(S1) = Uppercase(GetFilt(fInclude, I, ';')) Then Begin
       If Assigned(fFileFound) Then Begin
        If CheckSizeFile(SearchRec.Size) And CheckDateFile(PathToOk(Path) + SearchRec.Name) Then fFileFound(Self, Path, SearchRec);
       End;
      End;
     End;
    End
     else
    If Assigned(fFileFound) Then Begin
     If CheckSizeFile(SearchRec.Size) And CheckDateFile(PathToOk(Path) + SearchRec.Name) Then fFileFound(Self, Path, SearchRec);
    End;
   End;
   Res := FindNext(SearchRec);
  Until Res <> 0;
 End;
 FindClose(SearchRec);
End;

Procedure TlplFindFile.SearchDirectory(Path: String; Mask: String; Attr: Integer);
Var
 SearchRec: TSearchRec;
 Res: Integer;
 FName: String;
 DoCheckThisFolder: Boolean;
Begin
 Inc(RunningThreads);
 Inc(fCurrentSubCount);
 DoCheckThisFolder := true;
 If fSubs and (fSubsLevel > 0) then begin
  If fCurrentSubCount > fSubsLevel Then DoCheckThisFolder := False;
 End;
 If Assigned(fNewFolder) Then fNewFolder(Self, Path);
 If DoCheckThisFolder Then begin
  Res := FindFirst(PathToOk(Path) + '*.*', faDirectory, SearchRec);
  If Res = 0 Then Begin
   Repeat
    Application.ProcessMessages;
    FName := PathToOk(Path) + SearchRec.Name;
    If (SearchRec.Name = '.') or (SearchRec.Name = '..') Then Begin
     FName := '';
    End
     else
    Begin
     If (DirectoryExists(FName)) and (fSubs = True) Then begin
      SearchFiles(FName, Mask);
      SearchDirectory(FName, Mask, Attr);
     End;
    End;
    Res := FindNext(SearchRec);
   Until Res <> 0;
  End;
 End;
 Dec(fCurrentSubCount);
 Dec(RunningThreads);
 If RunningThreads = 0 Then Begin
  If (Assigned(fComplete)) And (RunSingle) Then fComplete(Self);
 End;
 FindClose(SearchRec);
End;

Procedure TlplFindFile.Search_Private;
Begin
// If Subs Then Begin
//  RunningThreads := 0;
  SearchFiles(fPath, fMask);
  SearchDirectory(fPath, fMask, faAnyFile);
// End
//  else
// Begin
//  If (Assigned(fComplete)) Then fComplete(Self);
// End;
End;

Procedure TlplFindFile.Search;
Begin
 Runsingle := True;
 Search_Private;
End;

Function TlplFindFile.PathToOk(APath: String): String;
Begin
 If APath = '' then begin
  Result := '';
  Exit;
 End;
 If APath[length(APath)] <> '\' Then APath := APath + '\';
 Result := APath;
End;

Procedure TlplFindFile.SearchDrives_Private(DriveList: String);
Var
 I: Integer;
Begin
 RunSingle := False;
 fSubs := True;
 If CountFilt(DriveList, ';') > 1 Then begin
  For I := 1 to CountFilt(DriveList, ';')-1 do begin
   fPath := Getfilt(DriveList, I, ';') + ':\';
   Search_Private;
  End;
 End;
 RunSingle := True;
 fPath := Getfilt(DriveList, CountFilt(Drivelist, ';'), ';') + ':\';
 Search_Private;
End;

Procedure TlplFindFile.SearchDriveList(Floppy, Fixed, Cd, Network, Ram: Boolean);
Var
 DriveList: String;
Begin
 DriveList := BuildDriveList(Floppy, Fixed, Cd, Network, Ram);
 SearchDrives_Private(DriveList);
End;

Procedure TlplFindFile.SearchDriveList(DriveList: String);
Begin
 SearchDrives_Private(DriveList);
End;

Function TlplFindFile.encodeAttr : integer;
begin
//  Result := 0;
//  if ReadOnly in Attr then result := result or faReadOnly;
//  if Hidden in Attr then result := result or faHidden;
//  if SysFile in Attr then result := result or faSysFile;
// result := result or faVolumeID;
//  if Archive in Attr then result := result or faArchive;
 Result := faArchive
end;

procedure TlplFindFile.SetEarlyDate(const Value: String);
begin
  fDateEarly := Value;
end;

procedure TlplFindFile.SetLateDate(const Value: String);
begin
  fDateLate := Value;
end;

procedure TlplFindFile.SetDateOption(const Value: TDateSearchMode);
begin
  fDateOption := Value;
end;

procedure TlplFindFile.SetSize(const Value: Int64);
begin
  fSize := Value;
end;

procedure TlplFindFile.SetSizeOption(const Value: TSizeSearchMode);
begin
  fSizeOption := Value;
end;

end.
