COMPOSANT TVUXFILESCANNER

unit VUXFileScanner;
{
Composant TVUXFileScanner

Développé par:
VUX (vux@fr.st)

Composant non visuel permettant de parcourir une arborescence de
répertoires/sous répertoires.

Petit bug connu: Pour parcourir les sous répertoires, la propriété
filter doit être obligatoirement : "*.*"

Version actuelle: 1.0

Mises à jour:
}
interface

uses
  Windows, Messages, SysUtils, Classes,FileCtrl;

type
  TDataFoundEvent = procedure(Sender :Tobject;FileName:String;
                const Filedata:TSearchRec;var Stop: Boolean) of object;
{ Evenement utilisé lorsque l' on a trouvé un fichier.
  
  \-Filename : Nom du fichier
  
  \-FileData : Informations sur le fichier
  
  \-Stop : Si vous le passez à True, le Scan est interrompu. }

  TFileAttributes = class(Tpersistent)
  public
    FatReadOnly : Boolean;
    FatHidden : Boolean;
    FatSysFile : Boolean;
    FatVolumeID : Boolean;
    FatDirectory : Boolean;
    FatArchive : Boolean;
    FatAnyFile : Boolean;
  published
    property atReadOnly : Boolean read FatReadOnly write fatreadonly;
    property atHidden : Boolean read FatHidden write FatHidden;
    property atSysFile : Boolean read FatSysFile write FatSysFile;
    property atVolumeID : Boolean read FatVolumeID write FatVolumeID;
    property atDirectory : Boolean read FatDirectory write FatDirectory;
    property atArchive : Boolean read FatArchive write FatArchive;
    property atAnyFile : Boolean read FatAnyFile write FatAnyFile;
  end;


  TVUXFileScanner = class(tcomponent)
  private
    FBaseDir,FFilter : string;
    FRecurse,FStop : Boolean;
    Fattrib : TFileAttributes;
    FOnDataFound : TDataFoundEvent;
    FOnScanComplete,FOnStop : TNotifyEvent;
    procedure EnumFiles(Basedir,Filter : string);
    procedure EnumFilesRec(Basedir,Filter : string);
    function GetAttrCode : Integer;
    procedure SetAttrib(Value : TFileAttributes);
  public
    constructor Create(AOwner :Tcomponent) ; override;
    procedure Scan;
    destructor Destroy;override;
  published
    Property Attributes : TFileAttributes read Fattrib write Setattrib;
    Property OnDataFound : TDataFoundEvent read FOnDataFound write FOnDataFound;
    Property OnScanComplete : TNotifyEvent read FOnScanComplete write FOnScanComplete;
    Property OnStop : TNotifyEvent read FOnStop write FonStop;
    Property Recurse : Boolean read Frecurse write Frecurse;
    Property BaseDir : string read FBaseDir write FBaseDir;
    Property Filter : string read FFilter write FFilter;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('VUX Utils', [TVUXFileScanner]);
end;

constructor TVUXFileScanner.Create(AOwner : Tcomponent);
begin
  inherited Create(AOWner);
  Fattrib := TFileAttributes.Create;
end;

destructor TVUXFileScanner.Destroy;
begin
  Fattrib.Free;
  inherited destroy;
end;

procedure TVUXFileScanner.SetAttrib(Value : TFileAttributes);
begin
  Fattrib.AssignTo(Value);
end;

procedure TVUXFileScanner.Scan;
begin
  FStop := False;
  if copy(FBaseDir,length(FBasedir),1) <> '\' then
    Fbasedir := Fbasedir + '\';
  if Frecurse then EnumFilesRec(FBaseDir,FFilter)
  else EnumFiles(FBaseDir,FFilter);

  If Fstop then begin
    If assigned(OnStop) then OnStop(self);
  end else
    If assigned(OnScanComplete) then OnscanComplete(self);
end;


function TVUXFileScanner.GetAttrCode : Integer;
var
Tmp : Integer;
begin
  Tmp := 0;
  If Fattrib.atAnyFile  then
    tmp := FaAnyFile
  else begin
    If Fattrib.atReadOnly then tmp := tmp + faReadOnly;
    If Fattrib.atHidden  then tmp := tmp + fahidden;
    If Fattrib.atSysFile then tmp := tmp + faSysFile;
    If Fattrib.atVolumeID then tmp := tmp + faVolumeID;
    If Fattrib.atDirectory then tmp := tmp + faDirectory;
    If Fattrib.atArchive then tmp := tmp + faArchive;
  end;
  Result := Tmp;
end;



procedure TVUXFileScanner.EnumFiles(Basedir,Filter : string);
var
Fdata: TSearchRec;
Search: string;
Hfile: integer;
begin
search := Basedir + Filter;
Hfile := findfirst(search,getattrcode,Fdata);
if (Hfile = 0) then
begin
        repeat
          if (Fdata.Name <> '.') and (Fdata.name <> '..') then begin
            If assigned(OnDataFound) then
              ondatafound(self,BaseDir + Fdata.Name,Fdata,FStop);
          end;
        until (FindNext(Fdata) <> 0) or FStop = True;
end;
findclose(fdata);
end;

procedure TVUXFileScanner.EnumFilesRec(Basedir,Filter : string);
var
Fdata: TSearchRec;
Search: string;
Hfile: integer;
begin
search := Basedir + Filter;
Hfile := findfirst(search,getattrcode,Fdata);
if (Hfile = 0) then
begin
        repeat
          if (Fdata.Name <> '.') and (Fdata.name <> '..') then begin
            If assigned(OnDataFound) then
              ondatafound(self,BaseDir + Fdata.Name,Fdata,Fstop);
            if Directoryexists(Basedir + Fdata.name) then begin
              EnumFilesRec(Basedir + fdata.Name + '\',Filter);
            end;
          end;
        until (FindNext(Fdata) <> 0) or FStop = True;
end;
findclose(fdata);
end;

end.