unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls;
type
TShowStatusEvent = procedure(Id, ThId: Integer; Status, Task: String) of Object;
{ TMyThread }
TMyThread = class(TThread)
private
FId: Integer;
fStatusText : string;
fTaskText : string;
FOnShowStatus: TShowStatusEvent;
procedure SetId(AValue: Integer);
procedure ShowStatus;
protected
procedure Execute; override;
public
constructor Create(CreateSuspended : boolean);
property OnShowStatus: TShowStatusEvent read FOnShowStatus write FOnShowStatus;
property Id: Integer read FId write SetId;
end;
{ TForm1 }
TForm1 = class(TForm)
btStart: TButton;
btStop: TButton;
laTask: TLabel;
laStatus: TLabel;
lbThreads: TListBox;
StatusBar1: TStatusBar;
procedure btStartClick(Sender: TObject);
procedure btStopClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
procedure ShowStatus(Id, ThId: Integer; Status, Task: string);
procedure ThreadTerminated(Sender: TObject);
public
end;
var
Form1: TForm1;
aThreads: array[0..1] of TMyThread;
implementation
{$R *.lfm}
{ TMyThread }
procedure TMyThread.ShowStatus;
begin
if Assigned(FOnShowStatus) then begin
FOnShowStatus(FId, ThreadID, fStatusText, fTaskText);
end;
end;
procedure TMyThread.SetId(AValue: Integer);
begin
if FId=AValue then Exit;
FId:=AValue;
end;
procedure TMyThread.Execute;
var i: Integer;
begin
fStatusText := 'Starting...';
Synchronize(@ShowStatus);
fStatusText := 'Running...';
while (not Terminated) do begin //repeat all tasks
for i:= 1 to 9 do begin
if Terminated then Break; //abort
fTaskText:='Task no '+i.ToString;
sleep(500);
if not Terminated then
Synchronize(@Showstatus);
end;
end;
end;
constructor TMyThread.Create(CreateSuspended: boolean);
begin
inherited Create(CreateSuspended);
end;
{ TForm1 }
procedure TForm1.btStartClick(Sender: TObject);
var i: Integer;
begin
btStart.Enabled:=False;
lbThreads.Clear;
for i:= Low(aThreads) to High(aThreads) do
lbThreads.Items.Add('.');
for i:= Low(aThreads) to High(aThreads) do begin
aThreads[i] := TMyThread.Create(true);
aThreads[i].FreeOnTerminate := True;
aThreads[i].OnShowStatus := @ShowStatus;
aThreads[i].OnTerminate := @ThreadTerminated;
aThreads[i].Id:=i;
laStatus.Caption:='Started';
aThreads[i].Start;
end;
btStop.Enabled:=True;
end;
procedure TForm1.btStopClick(Sender: TObject);
var i: Integer;
begin
btStop.Enabled:=False;
for i:= Low(aThreads) to High(aThreads) do begin
aThreads[i].Terminate;
aThreads[i].WaitFor;
end;
laStatus.Caption:='Terminated';
btStart.Enabled:=True;
if Assigned(aThreads[0]) then ShowMessage('Assigned!');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
btStop.Enabled:=False;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var i: Integer;
begin
for i:= Low(aThreads) to High(aThreads) do begin
if Assigned(aThreads[i]) then begin
aThreads[i].Terminate;
aThreads[i].WaitFor;
end;
end;
end;
procedure TForm1.ShowStatus(Id, ThId: Integer; Status, Task: string);
const TXT='%S(%D/%D/%D)=%S';
var cThId: Integer;
begin
laStatus.Caption := Status;
laTask.Caption := Task;
cThId := GetCurrentThreadId;
lbThreads.Items[Id] := Format(TXT, [Status, Id, ThId, cThId, Task]);
end;
procedure TForm1.ThreadTerminated(Sender: TObject);
begin
if Sender is TMyThread then aThreads[(Sender as TMyThread).Id] := nil;
end;
end.