Vandaag eens aan het stoeien geweest met Threads, gebruik ze eigenlijk nooit.
Uiteindelijk is het me gelukt om een SearchThread te bouwen welke bedoeld is om op de fileserver alle onnodige files van gebruikers op te schonen (delete functie zit er nog niet in).
Sommige gebruikers met roaming profiles hebben lokaal op een laptop hun hele muziek en video collectie erin staan welke met uitloggen netjes gesynced wordt.
Tevens staan er her en der ook nog het nodige aan deze files.
De zoektoch begint dan ook met alle MP3/MP4/AVI/MPG
Ik heb dan ook op alle drives een folder TEST gemaakt met bestanden erin. De uitkomst klopt in het overzicht,
Ben dan ook zeer benieuwd of onderstaand een beetje klopt en waar ik eventueel wat gemist heb.
Gr
Herby
Code:
unit uThreadTest;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.Types, StrUtils;
type
//---------------------------------------------------------------------------\\
TSearchThread = class(TThread)
private
FCurrentFolder : string;
FExtensionsArray : TStringDynArray;
FFilesFound : TStringList;
procedure UpdatelbFilesFound;
procedure FindFiles (PathName: string);
protected
procedure Execute; override;
public
constructor Create (SearchDriveOrFolder, SearchExtensions: string);
property Folder : string read FCurrentFolder;
End;
//---------------------------------------------------------------------------\\
TSearchForm = class(TForm)
edtExtensions: TEdit;
Label1 : TLabel;
btnGo : TButton;
lbFilesFound : TListBox;
Label2 : TLabel;
Label3 : TLabel;
Memo1 : TMemo;
CheckBox1 : TCheckBox;
btnStop : TButton;
procedure FormCreate (Sender: TObject);
procedure FormDestroy (Sender: TObject);
procedure btnGoClick (Sender: TObject);
procedure btnStopClick(Sender: TObject);
private
FSearchThread : TSearchThread;
FThreadQueue : TStringList;
procedure ThreadTerminate(Sender: TObject);
procedure StartThreads;
procedure StartThread;
public
end;
//---------------------------------------------------------------------------\\
var
SearchForm : TSearchForm;
const
MaxNrOfThreads = 4;
implementation
uses
Math;
{$R *.dfm}
//---------------------------------------------------------------------------\\
constructor TSearchThread.Create(SearchDriveOrFolder, SearchExtensions: string);
var
I : Integer;
begin
inherited Create(True);
FCurrentFolder := SearchDriveOrFolder;
FExtensionsArray := SplitString (SearchExtensions, ';');
for I := 0 to length(FExtensionsArray) -1 do
if Not (AnsiLeftStr(FExtensionsArray[I],1) = '.') then
FExtensionsArray[I] := '.' + LowerCase(FExtensionsArray[I])
else
FExtensionsArray[I] := LowerCase(FExtensionsArray[I]);
end;
//---------------------------------------------------------------------------\\
function StringInArray(Value: string; Strings: array of string): Boolean;
var I: Integer;
begin
Result := False;
for I := Low(Strings) to High(Strings) do
Result := Result or (Value = Strings[I]);
end;
procedure TSearchThread.FindFiles (PathName: string);
var
SearchRec: TSearchRec;
Path : String;
begin
Path := IncludeTrailingPathDelimiter(PathName);
if FindFirst(Path + '*.*', faAnyFile - faDirectory, SearchRec) = 0 then
try
repeat
if True then
if StringInArray( LowerCase(ExtractFileExt(SearchRec.Name)) , FExtensionsArray) then
FFilesFound.Add(Path + SearchRec.Name);
until FindNext(SearchRec) <> 0;
finally
FindClose(SearchRec);
end;
if FindFirst(Path + '*.*', faDirectory, SearchRec) = 0 then
try
repeat
if ((SearchRec.Attr and faDirectory) <> 0) and (SearchRec.Name <> '.') and
(SearchRec.Name <> '..') then
FindFiles(Path + SearchRec.Name);
until FindNext(SearchRec) <> 0;
finally
FindClose(SearchRec);
end;
end;
//---------------------------------------------------------------------------\\
procedure TSearchThread.Execute;
begin
FFilesFound := TStringList.Create;
try
FindFiles (FCurrentFolder);
Synchronize (UpdatelbFilesFound);
finally
FFilesFound.Free;
end;
end;
//---------------------------------------------------------------------------\\
procedure TSearchThread.UpdatelbFilesFound;
begin
With SearchForm.lbFilesFound.Items do
begin
BeginUpdate;
AddStrings(FFilesFound);
EndUpdate;
end;
end;
//---------------------------------------------------------------------------\\
//---------------------------------------------------------------------------\\
//---------------------------------------------------------------------------\\
procedure TSearchForm.FormCreate(Sender: TObject);
begin
FThreadQueue := TStringList.Create;
end;
//---------------------------------------------------------------------------\\
procedure TSearchForm.FormDestroy(Sender: TObject);
begin
FThreadQueue.Free;
end;
//---------------------------------------------------------------------------\\
procedure TSearchForm.ThreadTerminate(Sender: TObject);
begin
if FThreadQueue.Count > 0 then
StartThread;
if FThreadQueue.Count = 0 then
lbFilesFound.Sorted := true;
end;
//---------------------------------------------------------------------------\\
procedure TSearchForm.StartThreads;
var
i : Integer;
begin
for i := 1 to Min(MaxNrOfThreads, FThreadQueue.Count) do
StartThread;
end;
//---------------------------------------------------------------------------\\
procedure TSearchForm.StartThread;
var
DriveOrFolder : string;
begin
DriveOrFolder := FThreadQueue[0];
FThreadQueue.Delete(0);
FSearchThread := TSearchThread.Create(DriveOrFolder, edtExtensions.Text);
FSearchThread.OnTerminate := ThreadTerminate;
FSearchThread.Start;
end;
//---------------------------------------------------------------------------\\
procedure TSearchForm.btnGoClick(Sender: TObject);
var
LogicalDrives : Dword;
i : Integer;
begin
Memo1.Lines.Clear;
lbFilesFound.Clear;
LogicalDrives := GetLogicalDrives;
for i := 0 to 25 do
if (LogicalDrives and (1 shl i)) <> 0 then
Begin
if CheckBox1.Checked then
begin
FThreadQueue.Append(Char(Ord('A') + i) + ':\TEST');
Memo1.Lines.Add(Char(Ord('A') + i) + ':\TEST')
end
else
begin
FThreadQueue.Append(Char(Ord('A') + i) + ':\');
Memo1.Lines.Add(Char(Ord('A') + i) + ':\')
end;
End;
StartThreads;
end;
//---------------------------------------------------------------------------\\
procedure TSearchForm.btnStopClick(Sender: TObject);
begin
if FThreadQueue.Count > 0 then
FSearchThread.Terminate;
end;
//---------------------------------------------------------------------------\\
end.
Bookmarks