We help IT Professionals succeed at work.
Get Started

Thread for each

systan
systan asked
on
681 Views
Last Modified: 2013-11-23
I'd like to scan all drives at the same time, however I can't make a code too fast;

If there is one delphi expert could make a Thread for each drive that scans a file,  then this will be the code structure;
3 drives,  drive c, drive d, drive e
Drives must be in a TCheckListBox;
heres the code:
///////////////////
procedure TForm1.showdrives;
var
  DType: Integer;
  Drive: Char;
begin
CheckListBox1.Clear;
  For Drive := 'A' To 'Z' Do
  Begin
   if (GetDriveType(PChar(Drive + ':\'))= DRIVE_FIXED) OR (GetDriveType(PChar(Drive + ':\'))= DRIVE_REMOVABLE) then
   begin
        CheckListBox1.Items.Add(Format('%s:\',[Drive])  );
   end;
 end;

end;
/////////////////
//// no file filtering is ok

When 3 drives are Checked and scan(clicked once),   3 Labels must contain an active scanned file;
First Label1 is use for drive C actively scanned files
Second Label2 is use for drive D actively scanned files
Third Label3 is use for drive E actively scanned files

Each drive has each own thread;  If we will watch the threads on task_manager there should be 4 threads running.

How would we do this?

I don't know if this post sounds demanding, but I'm trying to learn each code of an experts help.


Thank you
I hope someone could do this;


As a code reference for multit-threading;
This code proceduces multih-threaded file scanning;
unit Unit1;

interface

uses SyncObjs,
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Masks, ComCtrls, ExtCtrls;



type
  TScanFileEvent=procedure(Sender:TObject; Filename:string) of object;
  TScanErrorEvent=procedure(Sender:TObject; Filename:string; Error:Exception) of object;

  TScanningThread=class(TThread)
  private
    FCS:TCriticalSection;
    FIndex:integer;
    fn:string;
    err:Exception;
    FList:TStringList;
    FOnFinishedScanFile: TScanFileEvent;
    FOnAbortedScanFile: TScanFileEvent;
    FOnStartScanFile: TScanFileEvent;
    FOnFound: TScanFileEvent;
    FOnError: TScanErrorEvent;

    FLock : TMultiReadExclusiveWriteSynchronizer;


    procedure DoStartScan;
    procedure DoFinishScan;
    procedure DoAbortScan;
    procedure DoFound;
    procedure DoError;
    function GetThreadName: string;

  protected
    procedure execute; override;

  public
    constructor Create(AIndex:integer);
    destructor Destroy; override;
    procedure scan(AFilename:string);
    function IsScannig:boolean;

    property OnStartScanFile:TScanFileEvent read FOnStartScanFile write FOnStartScanFile;
    property OnFinishedScanFile:TScanFileEvent read FOnFinishedScanFile write FOnFinishedScanFile;
    property OnAbortedScanFile:TScanFileEvent read FOnAbortedScanFile write FOnAbortedScanFile;
    property OnFound:TScanFileEvent read FOnFound write FOnFound;
    property OnError:TScanErrorEvent read FOnError write FOnError;
    property ThreadName:string read GetThreadName;
    property FileName:string read fn;

    Property Lock : TMultiReadExclusiveWriteSynchronizer read FLock;
  end;



type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Memo1: TMemo;
    Memo2: TMemo;
    Label1: TLabel;
    StatusBar1: TStatusBar;
    Timer1: TTimer;
    Label2: TLabel;

    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private

    AThread : TScanningThread;
    cancelled:boolean;
    masks:array of TMask;
    total, scanned:integer;

    procedure startscan(sender:tobject; filename:string);
    procedure finishscan(sender:tobject; filename:string);
    procedure abortscan(sender:tobject; filename:string);
    procedure found(sender:tobject; filename:string);
    procedure error(sender:tobject; Filename:string; error:exception);
    function shouldScan(s:string):boolean;
    procedure scanMasks(s:string);

  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  MaxThread : byte;

implementation

{$R *.dfm}

var cs:TCriticalSection=nil;


{ TScanningThread }
constructor TScanningThread.Create(AIndex:integer);
begin
  FCS:=TCriticalSection.Create;
  FList:=TStringList.Create;
  FIndex:=AIndex;
  FLock := TMultiReadExclusiveWriteSynchronizer.Create;
  inherited Create(true);
end;

destructor TScanningThread.Destroy;
begin
  freeandnil(FList);
  freeandnil(FCS);
  freeandnil(FLock);
  inherited;
end;

procedure TScanningThread.DoAbortScan;
begin
  FOnAbortedScanFile(self, fn);
end;

procedure TScanningThread.DoError;
begin
  FOnError(self, fn, err);
end;

procedure TScanningThread.DoFinishScan;
begin
  OnFinishedScanFile(self, fn);
end;

procedure TScanningThread.DoStartScan;
begin
  OnStartScanFile(self, fn);
end;

procedure TScanningThread.DoFound;
begin
  OnFound(self, fn);
end;

procedure TScanningThread.execute;
var ie: integer;
begin
  while not terminated do
  try
    fn:='';
    FCS.Acquire;// extract first file if any (FIFO)
    try
       if FList.Count>0 then
      begin
        fn:=FList[0];
        FList.Delete(0);
      end;
    finally
      FCS.Release;
    end;


    if fn='' then// no file? go to sleep and get next file when woken up
    begin
      suspend;
      continue;
    end;


    try
      Synchronize(DoStartScan);

      if Terminated then
        Synchronize(DoAbortScan)
      else
        Synchronize(DoFinishScan);
    finally
    end;

  except
    on e:exception do
    begin
      err:=e;
      Synchronize(DoError);
    end;
  end;


end;

function TScanningThread.GetThreadName: string;
begin
result:='Thread '+inttostr(FIndex);
end;

function TScanningThread.IsScannig: boolean;
begin
result:=(not Suspended) or (FList.Count>0);
end;

procedure TScanningThread.scan(AFilename: string);
begin
Lock.BeginRead;
FList.Add(AFilename);
Lock.EndRead;
if Suspended then Resume;// wake up the thread if it's sleeping
end;


procedure TForm1.abortscan(sender: tobject; filename: string);
begin
  memo1.lines.add((sender as TScanningThread).ThreadName+' aborted while scanning file '+(sender as TScanningThread).Filename);
  inc(scanned);
end;

procedure TForm1.Button1Click(Sender: TObject);
var threads:array[0..5] of TScanningThread;
    i:integer;

  procedure findfiles(path:string);
  var r:tsearchrec;
  begin
    path:=IncludeTrailingPathDelimiter(path);

    if findfirst(path+'*.*', faanyfile-favolumeid, r)=0 then
    begin
      repeat
        AThread.Lock.BeginRead;
       
        if r.Attr and fadirectory=fadirectory then
        begin
          if (r.Name<>'.') and (r.Name<>'..') then findfiles(path+r.name);
        end
        else
        begin
          if shouldScan(path+r.name) then
          begin
            inc(total);
            threads[i].scan(path+r.name);
            i:=(i+1) mod MaxThread;// add each file to the next thread. when end of list, go the the first one
          end;
        end;

      //This shoud be removed, has system effects
      application.processmessages; // make sure GUI doesn't freeze;

      AThread.Lock.EndRead;
      until cancelled or (findnext(r)<>0);
      findclose(r);
    end;
  end;


begin

  timer1.enabled:=true;
  statusbar1.simpletext:='searching for files';
  total:=0;
  scanned:=0;
  cancelled:=false;
  memo1.Clear;
  memo2.Clear;
// user clicked scan

  for i:=1 to MaxThread do
  begin

    AThread := TScanningThread.Create(i);
    threads[i-1]:=TScanningThread.create(i);
    threads[i-1].OnStartScanFile:=startscan;
    threads[i-1].OnFinishedScanFile:=finishscan;
    threads[i-1].OnAbortedScanFile:=abortscan;
    threads[i-1].OnFound:=Found;
    threads[i-1].OnError:=error;

  end;

  try
    i:=0;
    findfiles('g:\');
    statusbar1.simpletext:='waiting for threads';
    // after finished searching for all files, wait for threads to finish
    repeat
      i:=0;
      while (i<MaxThread) and (not threads[i].IsScannig) do
        inc(i);
      //sleep(10);// do not kill the cpu
      //application.processmessages;// don't freeze the GUI
    until (i=MaxThread) or cancelled;// cancelled is a boolean value which is set to true when you click a cancel button
    if cancelled then
      memo1.lines.add('Scan aborted')
    else
      memo1.lines.add('Scan finished');
  finally
    statusbar1.simpletext:='finished';
    timer1.enabled:=false;
    for i:=1 to MaxThread do// terminate and destroy all threads
    begin
      threads[i-1].Terminate;
      threads[i-1].Resume;// just in case it's sleeping
      threads[i-1].WaitFor;
      //application.processmessages;// waitfor might take a little time so do not freeze the GUI
    end;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  cancelled:=true;
end;

procedure TForm1.finishscan(sender: tobject; filename: string);
begin
AThread.Lock.BeginWrite;
memo1.lines.add((sender as TScanningThread).ThreadName+' finished scanning file '+(sender as TScanningThread).Filename);
inc(scanned);
AThread.Lock.EndWrite;
end;

function TForm1.shouldScan(s: string): boolean;
var i:integer;
begin
  i:=0;
  while (i<length(masks)) and (not masks[i].matches(s)) do
    inc(i);
  result:=i<length(masks);
end;

procedure TForm1.startscan(sender: tobject; filename: string);
begin
AThread.Lock.BeginRead;
memo1.lines.add((sender as TScanningThread).ThreadName+' started scannig file '+(sender as TScanningThread).Filename);

AThread.Lock.EndRead;
end;

procedure TForm1.found(sender: tobject; filename: string);
begin
  memo2.lines.add('found in file '+filename);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
MaxThread := 4;
scanMasks('*.exe,*.dll');
end;

procedure TForm1.FormDestroy(Sender: TObject);
var i:integer;
begin
  for i:=1 to length(masks) do
    freeandnil(masks[i-1]);
  setlength(masks, 0);
  AThread.Free;
end;

procedure TForm1.error(sender: tobject; filename:string; error: exception);
var s:string;
begin
  s:='** Error while scannig file "'+filename+'": '+error.message;
  memo1.lines.add(s);
  inc(scanned);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  label1.caption:=format('Total: %d | Scanned: %d', [total, scanned]);
end;

procedure TForm1.scanMasks(s: string);
var l:TStringList;
    i:integer;
begin
  l:=TStringList.Create;
  try
    l.CommaText:=s;
    setlength(masks, l.count);
    for i:=1 to l.count do
      masks[i-1]:=TMask.Create(l[i-1]);
  finally
    freeandnil(l);
  end;
end;

initialization
cs:=TCriticalSection.create;

finalization
  freeandnil(cs);

end.

Open in new window

Comment
Watch Question
Top Expert 2010
Commented:
This problem has been solved!
Unlock 1 Answer and 12 Comments.
See Answer
Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

  • Troubleshooting
  • Research
  • Professional Opinions
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE