type
TfrmMain = class(TForm)
mmoMsg: TMemo;
btnNewThread: TButton;
btnShutdownAll: TButton;
procedure btnNewThreadClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btnShutdownAllClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TTestThread = class(TThread)
private
FSignalShutdown: Boolean;
FWinHandle: HWND;
FMemo: TMemo;
FMsg: String;
procedure DeallocateHwnd(Wnd: HWND);
procedure OnThreadTerminate(Sender: TObject);
procedure syncOutputMsg;
procedure doOutputMsg(const msg: string); overload;
procedure doOutputMsg(const fmtStr:string; const params: array of const); overload;
protected
procedure Execute; override;
procedure WndProc(var Msg: TMessage);
public
constructor Create(mmoOutput: TMemo);
destructor Destroy; override;
end;
var
frmMain: TfrmMain;
implementation
var
WM_SHUTDOWN_THREAD: Cardinal;
{$R *.fmx}
{ TTestThread }
constructor TTestThread.Create(mmoOutput: TMemo);
begin
FMemo := mmoOutput;
FSignalShutdown := False;
FWinHandle := AllocateHWnd(WndProc);
FreeOnTerminate := True;
OnTerminate := OnThreadTerminate;
inherited Create(False);
end;
procedure TTestThread.DeallocateHwnd(Wnd: HWND);
var
Instance: Pointer;
begin
Instance := Pointer(GetWindowLong(Wnd,GWL_WNDPROC));
if Instance <> @DefWindowProc then
SetWindowLong(Wnd,GWL_WNDPROC,LongInt(@DefWindowProc));
FreeObjectInstance(Instance);
DestroyWindow(Wnd);
end;
destructor TTestThread.Destroy;
begin
DeallocateHwnd(FWinHandle);
inherited;
end;
procedure TTestThread.OnThreadTerminate(Sender: TObject);
begin
frmMain.mmoMsg.Lines.Add('Thread ' + IntToStr(ThreadID) + ' shutting down.');
end;
procedure TTestThread.doOutputMsg(const msg: string);
begin
FMsg := msg;
Synchronize(syncOutputMsg);
end;
procedure TTestThread.doOutputMsg(const fmtStr:string; const params: array of const);
begin
FMsg := Format(fmtStr,params);
Synchronize(syncOutputMsg);
end;
procedure TTestThread.syncOutputMsg;
begin
if Assigned(FMemo) then FMemo.Lines.Add(FMsg);
end;
procedure TTestThread.Execute;
begin
inherited;
while not FSignalShutdown do
begin
Sleep(10);
doOutputMsg('Thid: %d, Time: %s',[ThreadID
,FormatDateTime('yyyy-mm-dd hh:nn:ss zzz',now)]);
end;
end;
procedure TTestThread.WndProc(var Msg: TMessage);
begin
if Msg.Msg = WM_SHUTDOWN_THREAD then
FSignalShutdown := True
else
Msg.Result := DefWindowProc(FWinHandle,Msg.Msg,Msg.WParam,Msg.LParam);
end;
procedure TfrmMain.btnNewThreadClick(Sender: TObject);
var
a: TTestThread;
begin
a := TTestThread.Create(frmMain.mmoMsg);
frmMain.mmoMsg.Lines.Add('Thread ' + IntToStr(a.ThreadID) + ' created.');
end;
procedure TfrmMain.btnShutdownAllClick(Sender: TObject);
begin
//SendMessage(wnd_broadcast, WM_SHUTDOWN_THREAD, 0, 0);
PostMessage(wnd_broadcast, WM_SHUTDOWN_THREAD, 0, 0);
end;
procedure TfrmMain.FormCreate(Sender: TObject);
begin
WM_SHUTDOWN_THREAD := RegisterWindowMessage('WM_SHUTDOWN_THREAD_001');
end;
end.