TMsgThread, TCommThread -- 在delphi线程中实现消息循环

http://delphi.cjcsoft.net//viewthread.php?tid=635

在delphi线程中实现消息循环

在delphi线程中实现消息循环

Delphi的TThread类使用很方便,但是有时候我们需要在线程类中使用消息循环,delphi没有提供.

花了两天的事件研究了一下win32的消息系统,写了一个线程内消息循环的测试.

但是没有具体应用过,贴出来给有这方面需求的DFW参考一下.希望大家和我讨论.

{-----------------------------------------------------------------------------
Unit Name: uMsgThread
Author:    xwing
eMail :    xwing@263.net ; MSN : xwing1979@hotmail.com
Purpose:   Thread with message Loop
History:

2003-6-19, add function to Send Thread Message.            ver 1.0
use Event List and waitforsingleObject
your can use WindowMessage or ThreadMessage
2003-6-18, Change to create a window to Recving message
2003-6-17, Begin.
-----------------------------------------------------------------------------}
unit uMsgThread;

interface
{$WARN SYMBOL_DEPRECATED OFF}
{$DEFINE USE_WINDOW_MESSAGE}
uses
Classes, windows, messages, forms, sysutils;

type
TMsgThread = class(TThread)
private
{$IFDEF USE_WINDOW_MESSAGE}
FWinName    : string;
FMSGWin     : HWND;
{$ELSE}
FEventList  : TList;
FCtlSect    : TRTLCriticalSection;
{$ENDIF}
FException  : Exception;
fDoLoop     : Boolean;
FWaitHandle : THandle;
{$IFDEF USE_WINDOW_MESSAGE}
procedure MSGWinProc(var Message: TMessage);
{$ELSE}
procedure ClearSendMsgEvent;
{$ENDIF}
procedure SetDoLoop(const Value: Boolean);
procedure WaitTerminate;

protected
Msg         :tagMSG;

procedure Execute; override;
procedure HandleException;
procedure DoHandleException;virtual;
//Inherited the Method to process your own Message
procedure DoProcessMsg(var Msg:TMessage);virtual;
//if DoLoop = true then loop this procedure
//Your can use the method to do some work needed loop.
procedure DoMsgLoop;virtual;
//Initialize Thread before begin message loop
procedure DoInit;virtual;
procedure DoUnInit;virtual;

procedure PostMsg(Msg:Cardinal;wParam:Integer;lParam:Integer);
//When Use SendMsg method Must not use Synchronize Method in ThreadLoop !!!
//otherwise will caurse DeadLock
procedure SendMsg(Msg:Cardinal;wParam:Integer;lParam:Integer);

public
constructor Create(Loop:Boolean=False;ThreadName: string='');
destructor destroy;override;
procedure AfterConstruction;override;

//postMessage to Quit,and Free(if FreeOnTerminater = true)
//can call this in thread loop, don't use terminate property.
procedure QuitThread;
//PostMessage to Quit and Wait, only call in MAIN THREAD
procedure QuitThreadWait;
//just like Application.processmessage.
procedure ProcessMessage;
//enable thread loop, no waitfor message
property DoLoop: Boolean read fDoLoop Write SetDoLoop;

end;

implementation

{ TMsgThread }
{//////////////////////////////////////////////////////////////////////////////}
constructor TMsgThread.Create(Loop:Boolean;ThreadName:string);
begin
{$IFDEF USE_WINDOW_MESSAGE}
if ThreadName <> '' then
FWinName := ThreadName
else
FWinName := 'Thread Window';
{$ELSE}
FEventList := TList.Create;
InitializeCriticalSection(fCtlSect);
{$ENDIF}

FWaitHandle := CreateEvent(nil, True, False, nil);

FDoLoop := Loop;            //default disable thread loop
inherited Create(False);    //Create thread
FreeOnTerminate := True;    //Thread quit and free object

//Call resume Method in Constructor Method
Resume;
//Wait until thread Message Loop started
WaitForSingleObject(FWaitHandle,INFINITE);
end;

{------------------------------------------------------------------------------}
procedure TMsgThread.AfterConstruction;
begin
end;

{------------------------------------------------------------------------------}
destructor TMsgThread.destroy;
begin
{$IFDEF USE_WINDOW_MESSAGE}
{$ELSE}
FEventList.Free;
DeleteCriticalSection(FCtlSect);
{$ENDIF}

inherited;
end;

{//////////////////////////////////////////////////////////////////////////////}
procedure TMsgThread.Execute;
var
mRet:Boolean;
aRet:Boolean;
{$IFNDEF USE_WINDOW_MESSAGE}
uMsg:TMessage;
{$ENDIF}
begin
{$IFDEF USE_WINDOW_MESSAGE}
FMSGWin := CreateWindow('STATIC',PChar(FWinName),WS_POPUP,0,0,0,0,0,0,hInstance,nil);
SetWindowLong(FMSGWin, GWL_WNDPROC, Longint(MakeObjectInstance(MSGWinProc)));
{$ELSE}
PeekMessage(Msg,0,WM_USER,WM_USER,PM_NOREMOVE); //Force system alloc a msgQueue
{$ENDIF}

//notify Conctructor can returen.
SetEvent(FWaitHandle);
CloseHandle(FWaitHandle);

mRet := True;
try
DoInit;
while mRet do   //Message Loop
begin
if fDoLoop then
begin
aRet := PeekMessage(Msg,0,0,0,PM_REMOVE);
if aRet and (Msg.message <> WM_QUIT) then
begin
{$IFDEF USE_WINDOW_MESSAGE}
TranslateMessage(Msg);
DispatchMessage(Msg);
{$ELSE}
uMsg.Msg := Msg.message;
uMsg.wParam := Msg.wParam;
uMsg.lParam := Msg.lParam;
DoProcessMsg(uMsg);
{$ENDIF}

if Msg.message = WM_QUIT then
mRet := False;
end;
{$IFNDEF USE_WINDOW_MESSAGE}
ClearSendMsgEvent;      //Clear SendMessage Event
{$ENDIF}
DoMsgLoop;
end
else begin
mRet := GetMessage(Msg,0,0,0);
if mRet then
begin
{$IFDEF USE_WINDOW_MESSAGE}
TranslateMessage(Msg);
DispatchMessage(Msg);
{$ELSE}
uMsg.Msg := Msg.message;
uMsg.wParam := Msg.wParam;
uMsg.lParam := Msg.lParam;
DoProcessMsg(uMsg);
ClearSendMsgEvent;      //Clear SendMessage Event
{$ENDIF}
end;
end;
end;
DoUnInit;
{$IFDEF USE_WINDOW_MESSAGE}
DestroyWindow(FMSGWin);
FreeObjectInstance(Pointer(GetWindowLong(FMSGWin, GWL_WNDPROC)));
{$ENDIF}
except
HandleException;
end;
end;

{------------------------------------------------------------------------------}
{$IFNDEF USE_WINDOW_MESSAGE}
procedure TMsgThread.ClearSendMsgEvent;
var
aEvent:PHandle;
begin
EnterCriticalSection(FCtlSect);
try
if FEventList.Count <> 0 then
begin
aEvent := FEventList.Items[0];
if aEvent <> nil then
begin
SetEvent(aEvent^);
CloseHandle(aEvent^);
Dispose(aEvent);
end;
FEventList.Delete(0);
end;
finally
LeaveCriticalSection(FCtlSect);
end;
end;
{$ENDIF}

{------------------------------------------------------------------------------}
procedure TMsgThread.HandleException;
begin
FException := Exception(ExceptObject);  //Get Current Exception object
try
if not (FException is EAbort) then
inherited Synchronize(DoHandleException);
finally
FException := nil;
end;
end;

{------------------------------------------------------------------------------}
procedure TMsgThread.DoHandleException;
begin
if FException is Exception then
Application.ShowException(FException)
else
SysUtils.ShowException(FException, nil);
end;

{//////////////////////////////////////////////////////////////////////////////}
{$IFDEF USE_WINDOW_MESSAGE}
procedure TMsgThread.MSGWinProc(var Message: TMessage);
begin
DoProcessMsg(Message);
with Message do
Result:=DefWindowProc(FMSGWin,Msg,wParam,lParam);
end;
{$ENDIF}

{------------------------------------------------------------------------------}
procedure TMsgThread.DoProcessMsg(var Msg:TMessage);
begin
end;

{------------------------------------------------------------------------------}
procedure TMsgThread.ProcessMessage;
{$IFNDEF USE_WINDOW_MESSAGE}
var
uMsg:TMessage;
{$ENDIF}
begin
while PeekMessage(Msg,0,0,0,PM_REMOVE) do
if Msg.message <> WM_QUIT then
begin
{$IFDEF USE_WINDOW_MESSAGE}
TranslateMessage(Msg);
DispatchMessage(msg);
{$ELSE}
uMsg.Msg := Msg.message;
uMsg.wParam := Msg.wParam;
uMsg.lParam := Msg.lParam;
DoProcessMsg(uMsg);
{$ENDIF}
end;
end;

{//////////////////////////////////////////////////////////////////////////////}
procedure TMsgThread.DoInit;
begin
end;

procedure TMsgThread.DoUnInit;
begin
end;

procedure TMsgThread.DoMsgLoop;
begin
Sleep(1);
end;

{//////////////////////////////////////////////////////////////////////////////}
procedure TMsgThread.QuitThread;
begin
{$IFDEF USE_WINDOW_MESSAGE}
PostMessage(FMSGWin,WM_QUIT,0,0);
{$ELSE}
PostThreadMessage(ThreadID,WM_QUIT,0,0);
{$ENDIF}
end;

{------------------------------------------------------------------------------}
procedure TMsgThread.QuitThreadWait;
begin
QuitThread;
WaitTerminate;
end;

{------------------------------------------------------------------------------}
procedure TMsgThread.SetDoLoop(const Value: Boolean);
begin
if Value = fDoLoop then Exit;
fDoLoop := Value;
if fDoLoop then
PostMsg(WM_USER,0,0);
end;

{------------------------------------------------------------------------------}
//Can only call this method in MAIN Thread!!
procedure TMsgThread.WaitTerminate;
var
xStart:Cardinal;
begin
xStart:=GetTickCount;
try
//EnableWindow(Application.Handle,False);
while WaitForSingleObject(Handle, 10) = WAIT_TIMEOUT do
begin
Application.ProcessMessages;
if GetTickCount > (xStart + 4000) then
begin
TerminateThread(Handle, 0);
Beep;
Break;
end;
end;
finally
//EnableWindow(Application.Handle,True);
end;
end;

{------------------------------------------------------------------------------}
procedure TMsgThread.PostMsg(Msg: Cardinal; wParam, lParam: Integer);
begin
{$IFDEF USE_WINDOW_MESSAGE}
postMessage(FMSGWin,Msg,wParam,lParam);
{$ELSE}
EnterCriticalSection(FCtlSect);
try
FEventList.Add(nil);
PostThreadMessage(ThreadID,Msg,wParam,lParam);
finally
LeaveCriticalSection(FCtlSect);
end;
{$ENDIF}
end;

{------------------------------------------------------------------------------}
procedure TMsgThread.SendMsg(Msg: Cardinal; wParam, lParam: Integer);
{$IFNDEF USE_WINDOW_MESSAGE}
var
aEvent:PHandle;
{$ENDIF}
begin
{$IFDEF USE_WINDOW_MESSAGE}
SendMessage(FMSGWin,Msg,wParam,lParam);
{$ELSE}
EnterCriticalSection(FCtlSect);
try
New(aEvent);
aEvent^ := CreateEvent(nil, True, False, nil);
FEventList.Add(aEvent);
PostThreadMessage(ThreadID,Msg,wParam,lParam);
finally
LeaveCriticalSection(FCtlSect);
end;
WaitForSingleObject(aEvent^,INFINITE);
{$ENDIF}
end;

end.

我参考了一下msdn,还有windows核心编程. 写了一个类来封装这个功能,不知道对不对.

里面使用了两个方法,一个使用一个隐含窗体来处理消息

还有一个是直接使用thread的消息队列来处理,但是这个时候sendmessage无法工作,

所以我自己设想了一个方法,虽然不完全达到了要求但是我简单测试了一下,好像还能工作.

切换两种工作方式要修改编译条件

{$DEFINE USE_WINDOW_MESSAGE} 使用隐含窗体来处理消息

{-$DEFINE USE_WINDOW_MESSAGE} 使用线程消息队列来处理消息

还有我想要等待线程开始进行消息循环的时候create函数才返回.

但是现在好像还没有这样(用一个事件来处理).只是开始进入了threadexecute函数,线程的create就返回了.可能会出问题.

通过设置 DoLoop属性可以设定线程是否循环(不阻塞等待消息),这样派生类线程在循环做一些其他事情的同时还可以接受消息. 例如:

派生类里面循环发送缓冲区的数据,还可以响应其他线程发送过来的消息(如停止,启动,退出,等等)

重新修改了一下，现在用起来基本没有问题了。

{ -----------------------------------------------------------------------------
Unit Name: uMsgThread
Author:    xwing
eMail :    xwing@263.net ; MSN : xwing1979@hotmail.com
Purpose:   Thread with message Loop
History:

2003-7-15  Write thread class without use delphi own TThread.
2003-6-19, add function to Send Thread Message.            ver 1.0
use Event List and waitforsingleObject
your can use WindowMessage or ThreadMessage
2003-6-18, Change to create a window to Recving message
2003-6-17, Begin.
----------------------------------------------------------------------------- }
unit uMsgThread;

interface

{$WARN SYMBOL_DEPRECATED OFF}
{$DEFINE USE_WINDOW_MESSAGE}

uses
Classes, windows, messages, forms, sysutils;

const
NM_EXECPROC = $8FFF;

type
EMsgThreadErr = class( Exception );

TMsgThreadMethod = procedure of object;

TMsgThread = class
private
SyncWindow : HWND;
FMethod : TMsgThreadMethod;
procedure SyncWindowProc( var Message : TMessage );

private
m_hThread : THandle;
threadid : DWORD;

{$IFDEF USE_WINDOW_MESSAGE}
FWinName : string;
FMSGWin : HWND;
{$ELSE}
FEventList : TList;
FCtlSect : TRTLCriticalSection;
{$ENDIF}
FException : Exception;
fDoLoop : Boolean;
FWaitHandle : THandle;

{$IFDEF USE_WINDOW_MESSAGE}
procedure MSGWinProc( var Message : TMessage );
{$ELSE}
procedure ClearSendMsgEvent;
{$ENDIF}
procedure SetDoLoop( const Value : Boolean );
procedure Execute;

protected
Msg : tagMSG;

{$IFNDEF USE_WINDOW_MESSAGE}
uMsg : TMessage;
fSendMsgComp : THandle;
{$ENDIF}
procedure HandleException;
procedure DoHandleException; virtual;

// Inherited the Method to process your own Message
procedure DoProcessMsg( var Msg : TMessage ); virtual;

// if DoLoop = true then loop this procedure
// Your can use the method to do some work needed loop.
procedure DoMsgLoop; virtual;

// Initialize Thread before begin message loop
procedure DoInit; virtual;
procedure DoUnInit; virtual;

procedure PostMsg( Msg : Cardinal; wParam : Integer; lParam : Integer );
// When Use SendMsg method Must not use Synchronize Method in ThreadLoop !!!
// otherwise will caurse DeadLock
function SendMsg( Msg : Cardinal; wParam : Integer; lParam : Integer )
: Integer;

public
constructor Create( Loop : Boolean = False; ThreadName : string = '' );
destructor destroy; override;

// Return TRUE if the thread exists. FALSE otherwise
function ThreadExists : BOOL;

procedure Synchronize( syncMethod : TMsgThreadMethod );

function WaitFor : Longword;
function WaitTimeOut( timeout : DWORD = 4000 ) : Longword;

// postMessage to Quit,and Free(if FreeOnTerminater = true)
// can call this in thread loop, don't use terminate property.
procedure QuitThread;

// just like Application.processmessage.
procedure ProcessMessage;

// enable thread loop, no waitfor message
property DoLoop : Boolean read fDoLoop write SetDoLoop;

end;

implementation

function msgThdInitialThreadProc( pv : Pointer ) : DWORD; stdcall;
var
obj : TMsgThread;
begin
obj := TMsgThread( pv );
obj.Execute;
Result := 0;
end;

{ TMsgThread }
{ ////////////////////////////////////////////////////////////////////////////// }
constructor TMsgThread.Create( Loop : Boolean; ThreadName : string );
begin
{$IFDEF USE_WINDOW_MESSAGE}
if ThreadName <> '' then
FWinName := ThreadName
else
FWinName := 'Thread Window';
{$ELSE}
FEventList := TList.Create;
InitializeCriticalSection( FCtlSect );
fSendMsgComp := CreateEvent( nil, True, False, nil );
{$ENDIF}

fDoLoop := Loop; // default disable thread loop

// Create a Window for sync method
SyncWindow := CreateWindow( 'STATIC', 'SyncWindow', WS_POPUP, 0, 0, 0, 0, 0,  0, hInstance, nil );
SetWindowLong( SyncWindow, GWL_WNDPROC,  Longint( MakeObjectInstance( SyncWindowProc ) ) );

FWaitHandle := CreateEvent( nil, True, False, nil );
// Create Thread
m_hThread := CreateThread( nil, 0, @msgThdInitialThreadProc, Self, 0, threadid );
if m_hThread = 0 then
raise EMsgThreadErr.Create( '不能创建线程。' );
// Wait until thread Message Loop started
WaitForSingleObject( FWaitHandle, INFINITE );
end;

{ ------------------------------------------------------------------------------ }
destructor TMsgThread.destroy;
begin
if m_hThread <> 0 then
QuitThread;
WaitFor;

// Free Sync Window
DestroyWindow( SyncWindow );
FreeObjectInstance( Pointer( GetWindowLong( SyncWindow, GWL_WNDPROC ) ) );

{$IFDEF USE_WINDOW_MESSAGE}

{$ELSE}
FEventList.Free;
DeleteCriticalSection( FCtlSect );
CloseHandle( fSendMsgComp );
{$ENDIF}

inherited;
end;

{ ////////////////////////////////////////////////////////////////////////////// }
procedure TMsgThread.Execute;
var
mRet : Boolean;
aRet : Boolean;
begin
{$IFDEF USE_WINDOW_MESSAGE}
FMSGWin := CreateWindow( 'STATIC', PChar( FWinName ), WS_POPUP, 0, 0, 0, 0, 0,  0, hInstance, nil );
SetWindowLong( FMSGWin, GWL_WNDPROC,  Longint( MakeObjectInstance( MSGWinProc ) ) );
{$ELSE}
PeekMessage( Msg, 0, WM_USER, WM_USER, PM_NOREMOVE );  // Force system alloc a msgQueue
{$ENDIF}

mRet := True;
try
DoInit;

// notify Conctructor can returen.
SetEvent( FWaitHandle );
CloseHandle( FWaitHandle );

while mRet do // Message Loop
begin
if fDoLoop then
begin
aRet := PeekMessage( Msg, 0, 0, 0, PM_REMOVE );
if aRet and ( Msg.Message <> WM_QUIT ) then
begin
{$IFDEF USE_WINDOW_MESSAGE}
TranslateMessage( Msg );
DispatchMessage( Msg );
{$ELSE}
uMsg.Msg := Msg.Message;
uMsg.wParam := Msg.wParam;
uMsg.lParam := Msg.lParam;
DoProcessMsg( uMsg );
{$ENDIF}
if Msg.Message = WM_QUIT then
mRet := False;
end;
{$IFNDEF USE_WINDOW_MESSAGE}
ClearSendMsgEvent; // Clear SendMessage Event
{$ENDIF}
DoMsgLoop;
end else begin
mRet := GetMessage( Msg, 0, 0, 0 );
if mRet then
begin
{$IFDEF USE_WINDOW_MESSAGE}
TranslateMessage( Msg );
DispatchMessage( Msg );
{$ELSE}
uMsg.Msg := Msg.Message;
uMsg.wParam := Msg.wParam;
uMsg.lParam := Msg.lParam;
DoProcessMsg( uMsg );
ClearSendMsgEvent; // Clear SendMessage Event
{$ENDIF}
end;
end;
end;
DoUnInit;
{$IFDEF USE_WINDOW_MESSAGE}
DestroyWindow( FMSGWin );
FreeObjectInstance( Pointer( GetWindowLong( FMSGWin, GWL_WNDPROC ) ) );
{$ENDIF}
except
HandleException;
end;
end;

{ ------------------------------------------------------------------------------ }
{$IFNDEF USE_WINDOW_MESSAGE}

procedure TMsgThread.ClearSendMsgEvent;
var
aEvent : PHandle;
begin
EnterCriticalSection( FCtlSect );
try
if FEventList.Count <> 0 then
begin
aEvent := FEventList.Items[ 0 ];
if aEvent <> nil then
begin
SetEvent( aEvent^ );
CloseHandle( aEvent^ );
Dispose( aEvent );
WaitForSingleObject( fSendMsgComp, INFINITE );
end;
FEventList.Delete( 0 );
end;
finally
LeaveCriticalSection( FCtlSect );
end;
end;
{$ENDIF}

{ ------------------------------------------------------------------------------ }
procedure TMsgThread.HandleException;
begin
FException := Exception( ExceptObject ); // Get Current Exception object
try
if not( FException is EAbort ) then
Synchronize( DoHandleException );
finally
FException := nil;
end;
end;

{ ------------------------------------------------------------------------------ }
procedure TMsgThread.DoHandleException;
begin
if FException is Exception then
Application.ShowException( FException )
else
sysutils.ShowException( FException, nil );
end;

{ ////////////////////////////////////////////////////////////////////////////// }
{$IFDEF USE_WINDOW_MESSAGE}

procedure TMsgThread.MSGWinProc( var Message : TMessage );
begin
DoProcessMsg( message );
if message.Msg < WM_USER then
with message do
Result := DefWindowProc( FMSGWin, Msg, wParam, lParam );
end;
{$ENDIF}

{ ------------------------------------------------------------------------------ }
procedure TMsgThread.DoProcessMsg( var Msg : TMessage );
begin

end;

{ ------------------------------------------------------------------------------ }
procedure TMsgThread.ProcessMessage;
{$IFNDEF USE_WINDOW_MESSAGE}
var
uMsg : TMessage;
{$ENDIF}
begin
while PeekMessage( Msg, 0, 0, 0, PM_REMOVE ) do
if Msg.Message <> WM_QUIT then
begin
{$IFDEF USE_WINDOW_MESSAGE}
TranslateMessage( Msg );
DispatchMessage( Msg );
{$ELSE}
uMsg.Msg := Msg.Message;
uMsg.wParam := Msg.wParam;
uMsg.lParam := Msg.lParam;
DoProcessMsg( uMsg );
{$ENDIF}
end;
end;

{ ////////////////////////////////////////////////////////////////////////////// }
procedure TMsgThread.DoInit;
begin
end;

procedure TMsgThread.DoUnInit;
begin
end;

procedure TMsgThread.DoMsgLoop;
begin
Sleep( 0 );
end;

{ ////////////////////////////////////////////////////////////////////////////// }
function TMsgThread.ThreadExists : BOOL;
begin
if m_hThread = 0 then
Result := False
else
Result := True;
end;

{ ------------------------------------------------------------------------------ }
procedure TMsgThread.QuitThread;
begin
{$IFDEF USE_WINDOW_MESSAGE}
PostMessage( FMSGWin, WM_QUIT, 0, 0 );
{$ELSE}
PostThreadMessage( threadid, WM_QUIT, 0, 0 );
{$ENDIF}
end;

{ ------------------------------------------------------------------------------ }
procedure TMsgThread.SetDoLoop( const Value : Boolean );
begin
if Value = fDoLoop then
Exit;
fDoLoop := Value;
if fDoLoop then
PostMsg( WM_USER, 0, 0 );
end;

{ ------------------------------------------------------------------------------ }
function TMsgThread.WaitTimeOut( timeout : DWORD ) : Longword;
var
xStart : Cardinal;
H : THandle;
begin
H := m_hThread;
xStart := GetTickCount;
while WaitForSingleObject( H, 10 ) = WAIT_TIMEOUT do
begin
Application.ProcessMessages;
if GetTickCount > ( xStart + timeout ) then
begin
TerminateThread( H, 0 );
Break;
end;
end;
GetExitCodeThread( H, Result );
end;

{ ------------------------------------------------------------------------------ }
function TMsgThread.WaitFor : Longword;
var
Msg : TMsg;
H : THandle;
begin
H := m_hThread;
if GetCurrentThreadID = MainThreadID then
while MsgWaitForMultipleObjects( 1, H, False, INFINITE, QS_SENDMESSAGE )
= WAIT_OBJECT_0 + 1 do
PeekMessage( Msg, 0, 0, 0, PM_NOREMOVE )
else
WaitForSingleObject( H, INFINITE );
GetExitCodeThread( H, Result );
end;

{ ------------------------------------------------------------------------------ }
procedure TMsgThread.PostMsg( Msg : Cardinal; wParam, lParam : Integer );
begin
{$IFDEF USE_WINDOW_MESSAGE}
PostMessage( FMSGWin, Msg, wParam, lParam );
{$ELSE}
EnterCriticalSection( FCtlSect );
try
FEventList.Add( nil );
PostThreadMessage( threadid, Msg, wParam, lParam );
finally
LeaveCriticalSection( FCtlSect );
end;
{$ENDIF}
end;

{ ------------------------------------------------------------------------------ }
function TMsgThread.SendMsg( Msg : Cardinal; wParam, lParam : Integer )
: Integer;
{$IFNDEF USE_WINDOW_MESSAGE}
var
aEvent : PHandle;
{$ENDIF}
begin
{$IFDEF USE_WINDOW_MESSAGE}
Result := SendMessage( FMSGWin, Msg, wParam, lParam );
{$ELSE}
EnterCriticalSection( FCtlSect );
try
New( aEvent );
aEvent^ := CreateEvent( nil, True, False, nil );
FEventList.Add( aEvent );
PostThreadMessage( threadid, Msg, wParam, lParam );
finally
LeaveCriticalSection( FCtlSect );
end;
WaitForSingleObject( aEvent^, INFINITE );
Result := uMsg.Result;
SetEvent( fSendMsgComp );
{$ENDIF}
end;

{ ------------------------------------------------------------------------------ }
procedure TMsgThread.Synchronize( syncMethod : TMsgThreadMethod );
begin
FMethod := syncMethod;
SendMessage( SyncWindow, NM_EXECPROC, 0, Longint( Self ) );
end;

{ ------------------------------------------------------------------------------ }
procedure TMsgThread.SyncWindowProc( var Message : TMessage );
begin
case message.Msg of
NM_EXECPROC :
with TMsgThread( message.lParam ) do
begin
message.Result := 0;
try
FMethod;
except
raise EMsgThreadErr.Create( '执行同步线程方法错误。' );
end;
end;
else
message.Result := DefWindowProc( SyncWindow, message.Msg, message.wParam,
message.lParam );
end;
end;

end.

http://www.techques.com/question/1-4073197/How-do-I-send-and-handle-message-between-TService-parent-thread-and-child-thread?

I took a look at OmniThreadLibrary and it looked like overkill for my purposes.

I wrote a simple library I call TCommThread.

It allows you to pass data back to the main thread without worrying about

any of the complexities of threads or Windows messages.

Here's the code if you'd like to try it.

CommThread Library:

unit Threading.CommThread;

interface

uses
Classes, SysUtils, ExtCtrls, SyncObjs, Generics.Collections, DateUtils;

const
CTID_USER = 1000;
PRM_USER = 1000;

CTID_STATUS = 1;
CTID_PROGRESS = 2;

type
TThreadParams = class(TDictionary<String, Variant>);
TThreadObjects = class(TDictionary<String, TObject>);

TCommThreadParams = class(TObject)
private
FThreadParams: TThreadParams;
FThreadObjects: TThreadObjects;
public
constructor Create;
destructor Destroy; override;

procedure Clear;

function GetParam(const ParamName: String): Variant;
function SetParam(const ParamName: String; ParamValue: Variant): TCommThreadParams;
function GetObject(const ObjectName: String): TObject;
function SetObject(const ObjectName: String; Obj: TObject): TCommThreadParams;
end;

TCommQueueItem = class(TObject)
private
FSender: TObject;
FMessageId: Integer;
FCommThreadParams: TCommThreadParams;
public
destructor Destroy; override;

property Sender: TObject read FSender write FSender;
property MessageId: Integer read FMessageId write FMessageId;
property CommThreadParams: TCommThreadParams read FCommThreadParams write FCommThreadParams;
end;

TCommQueue = class(TQueue<TCommQueueItem>);

ICommDispatchReceiver = interface
['{A4E2C9D1-E4E8-497D-A9BF-FAFE2D3A7C49}']
procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
procedure CommThreadTerminated(Sender: TObject);
function Cancelled: Boolean;
end;

TCommThread = class(TThread)
protected
FCommThreadParams: TCommThreadParams;
FCommDispatchReceiver: ICommDispatchReceiver;
FName: String;
FProgressFrequency: Integer;
FNextSendTime: TDateTime;

procedure SendStatusMessage(const StatusText: String; StatusType: Integer = 0); virtual;
procedure SendProgressMessage(ProgressID: Int64; Progress, ProgressMax: Integer; AlwaysSend: Boolean = TRUE); virtual;
public
constructor Create(CommDispatchReceiver: TObject); reintroduce; virtual;
destructor Destroy; override;

function SetParam(const ParamName: String; ParamValue: Variant): TCommThread;
function GetParam(const ParamName: String): Variant;
function SetObject(const ObjectName: String; Obj: TObject): TCommThread;
function GetObject(const ObjectName: String): TObject;
procedure SendCommMessage(MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;

property Name: String read FName;
end;

TCommThreadClass = Class of TCommThread;

TCommThreadQueue = class(TObjectList<TCommThread>);

TCommThreadDispatchState = (
ctsIdle,
ctsActive,
ctsTerminating
);

TOnReceiveThreadMessage = procedure(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams) of object;
TOnStateChange = procedure(Sender: TObject; State: TCommThreadDispatchState) of object;
TOnStatus = procedure(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer) of object;
TOnProgress = procedure(Source, Sender: TObject; const ID: String; Progress, ProgressMax: Integer) of object;

TBaseCommThreadDispatch = class(TComponent, ICommDispatchReceiver)
private
FProcessQueueTimer: TTimer;
FCSReceiveMessage: TCriticalSection;
FCSCommThreads: TCriticalSection;
FCommQueue: TCommQueue;
FActiveThreads: TList;
FCommThreadClass: TCommThreadClass;
FCommThreadDispatchState: TCommThreadDispatchState;

function CreateThread(const ThreadName: String = ''): TCommThread;
function GetActiveThreadCount: Integer;
function GetStateText: String;
protected
FOnReceiveThreadMessage: TOnReceiveThreadMessage;
FOnStateChange: TOnStateChange;
FOnStatus: TOnStatus;
FOnProgress: TOnProgress;
FManualMessageQueue: Boolean;
FProgressFrequency: Integer;

procedure SetManualMessageQueue(const Value: Boolean);
procedure SetProcessQueueTimerInterval(const Value: Integer);
procedure SetCommThreadDispatchState(const Value: TCommThreadDispatchState);
procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
procedure OnProcessQueueTimer(Sender: TObject);
function GetProcessQueueTimerInterval: Integer;

procedure CommThreadTerminated(Sender: TObject); virtual;
function Finished: Boolean; virtual;

procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;
procedure DoOnStateChange; virtual;

procedure TerminateActiveThreads;

property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
property OnStatus: TOnStatus read FOnStatus write FOnStatus;
property OnProgress: TOnProgress read FOnProgress write FOnProgress;

property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
property CommThreadDispatchState: TCommThreadDispatchState read FCommThreadDispatchState write SetCommThreadDispatchState;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;

function NewThread(const ThreadName: String = ''): TCommThread; virtual;
procedure ProcessMessageQueue; virtual;
procedure Stop; virtual;
function State: TCommThreadDispatchState;
function Cancelled: Boolean;

property ActiveThreadCount: Integer read GetActiveThreadCount;
property StateText: String read GetStateText;

property CommThreadClass: TCommThreadClass read FCommThreadClass write FCommThreadClass;
end;

TCommThreadDispatch = class(TBaseCommThreadDispatch)
published
property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;

property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
end;

TBaseStatusCommThreadDispatch = class(TBaseCommThreadDispatch)
protected
FOnStatus: TOnStatus;
FOnProgress: TOnProgress;

procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); override;

procedure DoOnStatus(Sender: TObject;const ID: String; const StatusText: String; StatusType: Integer); virtual;
procedure DoOnProgress(Sender: TObject; const ID: String; Progress, ProgressMax: Integer); virtual;

property OnStatus: TOnStatus read FOnStatus write FOnStatus;
property OnProgress: TOnProgress read FOnProgress write FOnProgress;
end;

TStatusCommThreadDispatch = class(TBaseStatusCommThreadDispatch)
published
property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
property OnStatus: TOnStatus read FOnStatus write FOnStatus;
property OnProgress: TOnProgress read FOnProgress write FOnProgress;

property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
end;

implementation

const
PRM_STATUS_TEXT = 'Status';
PRM_STATUS_TYPE = 'Type';
PRM_PROGRESS_ID = 'ProgressID';
PRM_PROGRESS = 'Progess';
PRM_PROGRESS_MAX = 'ProgressMax';

resourcestring
StrCommReceiverMustSupportInterface = 'CommDispatchReceiver must support ICommDispatchReceiver interface';
StrSenderMustBeATCommThread = 'Sender must be a TCommThread';
StrUnableToFindTerminatedThread = 'Unable to find the terminated thread';
StrIdle = 'Idle';
StrTerminating = 'Terminating';
StrActive = 'Active';

{ TCommThread }

constructor TCommThread.Create(CommDispatchReceiver: TObject);
begin
Assert(Supports(CommDispatchReceiver, ICommDispatchReceiver, FCommDispatchReceiver), StrCommReceiverMustSupportInterface);

inherited Create(TRUE);

FCommThreadParams := TCommThreadParams.Create;
end;

destructor TCommThread.Destroy;
begin
FCommDispatchReceiver.CommThreadTerminated(Self);

FreeAndNil(FCommThreadParams);

inherited;
end;

function TCommThread.GetObject(const ObjectName: String): TObject;
begin
Result := FCommThreadParams.GetObject(ObjectName);
end;

function TCommThread.GetParam(const ParamName: String): Variant;
begin
Result := FCommThreadParams.GetParam(ParamName);
end;

procedure TCommThread.SendCommMessage(MessageId: Integer;
CommThreadParams: TCommThreadParams);
begin
FCommDispatchReceiver.QueueMessage(Self, MessageId, CommThreadParams);
end;

procedure TCommThread.SendProgressMessage(ProgressID: Int64; Progress,
ProgressMax: Integer; AlwaysSend: Boolean);
begin
if (AlwaysSend) or (now > FNextSendTime) then
begin
// Send a status message to the comm receiver
SendCommMessage(CTID_PROGRESS, TCommThreadParams.Create
.SetParam(PRM_PROGRESS_ID, ProgressID)
.SetParam(PRM_PROGRESS, Progress)
.SetParam(PRM_PROGRESS_MAX, ProgressMax));

if not AlwaysSend then
FNextSendTime := now + (FProgressFrequency * OneMillisecond);
end;
end;

procedure TCommThread.SendStatusMessage(const StatusText: String;
StatusType: Integer);
begin
// Send a status message to the comm receiver
SendCommMessage(CTID_STATUS, TCommThreadParams.Create
.SetParam(PRM_STATUS_TEXT, StatusText)
.SetParam(PRM_STATUS_TYPE, StatusType));
end;

function TCommThread.SetObject(const ObjectName: String;
Obj: TObject): TCommThread;
begin
Result := Self;

FCommThreadParams.SetObject(ObjectName, Obj);
end;

function TCommThread.SetParam(const ParamName: String;
ParamValue: Variant): TCommThread;
begin
Result := Self;

FCommThreadParams.SetParam(ParamName, ParamValue);
end;

{ TCommThreadDispatch }

function TBaseCommThreadDispatch.Cancelled: Boolean;
begin
Result := State = ctsTerminating;
end;

procedure TBaseCommThreadDispatch.CommThreadTerminated(Sender: TObject);
var
idx: Integer;
begin
FCSCommThreads.Enter;
try
Assert(Sender is TCommThread, StrSenderMustBeATCommThread);

// Find the thread in the active thread list
idx := FActiveThreads.IndexOf(Sender);

Assert(idx <> -1, StrUnableToFindTerminatedThread);

// if we find it, remove it (we should always find it)
FActiveThreads.Delete(idx);
finally
FCSCommThreads.Leave;
end;
end;

constructor TBaseCommThreadDispatch.Create(AOwner: TComponent);
begin
inherited;

FCommThreadClass := TCommThread;

FProcessQueueTimer := TTimer.Create(nil);
FProcessQueueTimer.Enabled := FALSE;
FProcessQueueTimer.Interval := 5;
FProcessQueueTimer.OnTimer := OnProcessQueueTimer;
FProgressFrequency := 200;

FCommQueue := TCommQueue.Create;

FActiveThreads := TList.Create;

FCSReceiveMessage := TCriticalSection.Create;
FCSCommThreads := TCriticalSection.Create;
end;

destructor TBaseCommThreadDispatch.Destroy;
begin
// Stop the queue timer
FProcessQueueTimer.Enabled := FALSE;

TerminateActiveThreads;

// Pump the queue while there are active threads
while CommThreadDispatchState <> ctsIdle do
begin
ProcessMessageQueue;

sleep(10);
end;

// Free everything
FreeAndNil(FProcessQueueTimer);
FreeAndNil(FCommQueue);
FreeAndNil(FCSReceiveMessage);
FreeAndNil(FCSCommThreads);
FreeAndNil(FActiveThreads);

inherited;
end;

procedure TBaseCommThreadDispatch.DoOnReceiveThreadMessage(Sender: TObject;
MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
// Don't send the messages if we're being destroyed
if not (csDestroying in ComponentState) then
begin
if Assigned(FOnReceiveThreadMessage) then
FOnReceiveThreadMessage(Self, Sender, MessageId, CommThreadParams);
end;
end;

procedure TBaseCommThreadDispatch.DoOnStateChange;
begin
if (Assigned(FOnStateChange)) and (not (csDestroying in ComponentState)) then
FOnStateChange(Self, FCommThreadDispatchState);
end;

function TBaseCommThreadDispatch.GetActiveThreadCount: Integer;
begin
Result := FActiveThreads.Count;
end;

function TBaseCommThreadDispatch.GetProcessQueueTimerInterval: Integer;
begin
Result := FProcessQueueTimer.Interval;
end;

function TBaseCommThreadDispatch.GetStateText: String;
begin
case State of
ctsIdle: Result := StrIdle;
ctsTerminating: Result := StrTerminating;
ctsActive: Result := StrActive;
end;
end;

function TBaseCommThreadDispatch.NewThread(const ThreadName: String): TCommThread;
begin
if FCommThreadDispatchState = ctsTerminating then
Result := nil
else
begin
// Make sure we're active
if CommThreadDispatchState = ctsIdle then
CommThreadDispatchState := ctsActive;

Result := CreateThread(ThreadName);

FActiveThreads.Add(Result);

if ThreadName = '' then
Result.FName := IntToStr(Integer(Result))
else
Result.FName := ThreadName;

Result.FProgressFrequency := FProgressFrequency;
end;
end;

function TBaseCommThreadDispatch.CreateThread(
const ThreadName: String): TCommThread;
begin
Result := FCommThreadClass.Create(Self);

Result.FreeOnTerminate := TRUE;
end;

procedure TBaseCommThreadDispatch.OnProcessQueueTimer(Sender: TObject);
begin
ProcessMessageQueue;
end;

procedure TBaseCommThreadDispatch.ProcessMessageQueue;
var
CommQueueItem: TCommQueueItem;
begin
if FCommThreadDispatchState in [ctsActive, ctsTerminating] then
begin
if FCommQueue.Count > 0 then
begin
FCSReceiveMessage.Enter;
try
CommQueueItem := FCommQueue.Dequeue;

while Assigned(CommQueueItem) do
begin
try
DoOnReceiveThreadMessage(CommQueueItem.Sender, CommQueueItem.MessageId, CommQueueItem.CommThreadParams);
finally
FreeAndNil(CommQueueItem);
end;

if FCommQueue.Count > 0 then
CommQueueItem := FCommQueue.Dequeue;
end;
finally
FCSReceiveMessage.Leave
end;
end;

if Finished then
begin
FCommThreadDispatchState := ctsIdle;

DoOnStateChange;
end;
end;
end;

function TBaseCommThreadDispatch.Finished: Boolean;
begin
Result := FActiveThreads.Count = 0;
end;

procedure TBaseCommThreadDispatch.QueueMessage(Sender: TObject; MessageId: Integer;
CommThreadParams: TCommThreadParams);
var
CommQueueItem: TCommQueueItem;
begin
FCSReceiveMessage.Enter;
try
CommQueueItem := TCommQueueItem.Create;
CommQueueItem.Sender := Sender;
CommQueueItem.MessageId := MessageId;
CommQueueItem.CommThreadParams := CommThreadParams;

FCommQueue.Enqueue(CommQueueItem);
finally
FCSReceiveMessage.Leave
end;
end;

procedure TBaseCommThreadDispatch.SetCommThreadDispatchState(
const Value: TCommThreadDispatchState);
begin
if FCommThreadDispatchState <> ctsTerminating then
begin
if Value = ctsActive then
begin
if not FManualMessageQueue then
FProcessQueueTimer.Enabled := TRUE;
end
else
TerminateActiveThreads;
end;

FCommThreadDispatchState := Value;

DoOnStateChange;
end;

procedure TBaseCommThreadDispatch.SetManualMessageQueue(const Value: Boolean);
begin
FManualMessageQueue := Value;
end;

procedure TBaseCommThreadDispatch.SetProcessQueueTimerInterval(const Value: Integer);
begin
FProcessQueueTimer.Interval := Value;
end;

function TBaseCommThreadDispatch.State: TCommThreadDispatchState;
begin
Result := FCommThreadDispatchState;
end;

procedure TBaseCommThreadDispatch.Stop;
begin
if CommThreadDispatchState = ctsActive then
TerminateActiveThreads;
end;

procedure TBaseCommThreadDispatch.TerminateActiveThreads;
var
i: Integer;
begin
if FCommThreadDispatchState = ctsActive then
begin
// Lock threads
FCSCommThreads.Acquire;
try
FCommThreadDispatchState := ctsTerminating;

DoOnStateChange;

// Terminate each thread in turn
for i := 0 to pred(FActiveThreads.Count) do
TCommThread(FActiveThreads[i]).Terminate;
finally
FCSCommThreads.Release;
end;
end;
end;

{ TCommThreadParams }

procedure TCommThreadParams.Clear;
begin
FThreadParams.Clear;
FThreadObjects.Clear;
end;

constructor TCommThreadParams.Create;
begin
FThreadParams := TThreadParams.Create;
FThreadObjects := TThreadObjects.Create;
end;

destructor TCommThreadParams.Destroy;
begin
FreeAndNil(FThreadParams);
FreeAndNil(FThreadObjects);

inherited;
end;

function TCommThreadParams.GetObject(const ObjectName: String): TObject;
begin
Result := FThreadObjects.Items[ObjectName];
end;

function TCommThreadParams.GetParam(const ParamName: String): Variant;
begin
Result := FThreadParams.Items[ParamName];
end;

function TCommThreadParams.SetObject(const ObjectName: String;
Obj: TObject): TCommThreadParams;
begin
FThreadObjects.AddOrSetValue(ObjectName, Obj);

Result := Self;
end;

function TCommThreadParams.SetParam(const ParamName: String;
ParamValue: Variant): TCommThreadParams;
begin
FThreadParams.AddOrSetValue(ParamName, ParamValue);

Result := Self;
end;

{ TCommQueueItem }

destructor TCommQueueItem.Destroy;
begin
if Assigned(FCommThreadParams) then
FreeAndNil(FCommThreadParams);

inherited;
end;

{ TBaseStatusCommThreadDispatch }

procedure TBaseStatusCommThreadDispatch.DoOnReceiveThreadMessage(
Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
inherited;

case MessageId of
// Status Message
CTID_STATUS: DoOnStatus(Sender,
Name,
CommThreadParams.GetParam(PRM_STATUS_TEXT),
CommThreadParams.GetParam(PRM_STATUS_TYPE));
// Progress Message
CTID_PROGRESS: DoOnProgress(Sender,
CommThreadParams.GetParam(PRM_PROGRESS_ID),
CommThreadParams.GetParam(PRM_PROGRESS),
CommThreadParams.GetParam(PRM_PROGRESS_MAX));
end;
end;

procedure TBaseStatusCommThreadDispatch.DoOnStatus(Sender: TObject; const ID,
StatusText: String; StatusType: Integer);
begin
if (not (csDestroying in ComponentState)) and (Assigned(FOnStatus)) then
FOnStatus(Self, Sender, ID, StatusText, StatusType);
end;

procedure TBaseStatusCommThreadDispatch.DoOnProgress(Sender: TObject;
const ID: String; Progress, ProgressMax: Integer);
begin
if not (csDestroying in ComponentState) and (Assigned(FOnProgress)) then
FOnProgress(Self, Sender, ID, Progress, ProgressMax);
end;

end.

To use the library, simply descend your thread from the TCommThread thread and override the Execute procedure:

MyCommThreadObject = class(TCommThread)
public
procedure Execute; override;
end;

Next, create a descendant of the TStatusCommThreadDispatch component and set it's events.

MyCommThreadComponent := TStatusCommThreadDispatch.Create(Self);

// Add the event handlers
MyCommThreadComponent.OnStateChange := OnStateChange;
MyCommThreadComponent.OnReceiveThreadMessage := OnReceiveThreadMessage;
MyCommThreadComponent.OnStatus := OnStatus;
MyCommThreadComponent.OnProgress := OnProgress;

// Set the thread class
MyCommThreadComponent.CommThreadClass := TMyCommThread;

Make sure you set the CommThreadClass to your TCommThread descendant.

Now all you need to do is create the threads via MyCommThreadComponent:

FCommThreadComponent.NewThread
.SetParam('MyThreadInputParameter', '12345')
.SetObject('MyThreadInputObject', MyObject)
.Start;

Add as many parameters and objects as you like. In your threads Execute method you can retrieve the parameters and objects.

MyThreadParameter := GetParam('MyThreadInputParameter'); // 12345
MyThreadObject := GetObject('MyThreadInputObject'); // MyObject

Parameters will be automatically freed. You need to manage objects yourself.

To send a message back to the main thread from the threads execute method:

FCommDispatchReceiver.QueueMessage(Self, CTID_MY_MESSAGE_ID, TCommThreadParams.Create
.SetObject('MyThreadObject', MyThreadObject)
.SetParam('MyThreadOutputParameter', MyThreadParameter));

Again, parameters will be destroyed automatically, objects you have to manage yourself.

To receive messages in the main thread either attach the OnReceiveThreadMessage event

or override the DoOnReceiveThreadMessage procedure:

procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); override;

Use the overridden procedure to process the messages sent back to your main thread:

procedure THostDiscovery.DoOnReceiveThreadMessage(Sender: TObject;
MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
inherited;

case MessageId of

CTID_MY_MESSAGE_ID:
begin
// Process the CTID_MY_MESSAGE_ID message
DoSomethingWithTheMessage(CommThreadParams.GetParam('MyThreadOutputParameter'),
CommThreadParams.GeObject('MyThreadObject'));
end;
end;
end;

The messages are pumped in the ProcessMessageQueue procedure.

This procedure is called via a TTimer.

If you use the component in a console app you will need to call ProcessMessageQueue manually.

The timer will start when the first thread is created.

It will stop when the last thread has finished.

If you need to control when the timer stops you can override the Finished procedure.

You can also perform actions depending on the state of the threads by overriding the DoOnStateChange procedure.

Take a look at the TCommThread descendant TStatusCommThreadDispatch.

It implements the sending of simple Status and Progress messages back to the main thread.

I hope this helps and that I've explained it OK.

This is related to my previous answer, but I was limited to 30000 characters.

Here's the code for a test app that uses TCommThread:

Test App (.pas)

unit frmMainU;

interface

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

Threading.CommThread;

type
TMyCommThread = class(TCommThread)
public
procedure Execute; override;
end;

TfrmMain = class(TForm)
Panel1: TPanel;
lvLog: TListView;
btnStop: TButton;
btnNewThread: TButton;
StatusBar1: TStatusBar;
btn30NewThreads: TButton;
tmrUpdateStatusBar: TTimer;
procedure FormCreate(Sender: TObject);
procedure btnStopClick(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure tmrUpdateStatusBarTimer(Sender: TObject);
private
FCommThreadComponent: TStatusCommThreadDispatch;

procedure OnReceiveThreadMessage(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
procedure OnStateChange(Sender: TObject; State: TCommThreadDispatchState);
procedure UpdateStatusBar;
procedure OnStatus(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer);
procedure OnProgress(Source, Sender: TObject; const ID: String; Progress,  ProgressMax: Integer);
public

end;

var
frmMain: TfrmMain;

implementation

resourcestring
StrStatusIDDProgre = 'StatusID: %s, Progress: %d, ProgressMax: %d';
StrActiveThreadsD = 'Active Threads: %d, State: %s';
StrIdle = 'Idle';
StrActive = 'Active';
StrTerminating = 'Terminating';

{$R *.dfm}

{ TMyCommThread }

procedure TMyCommThread.Execute;
var
i: Integer;
begin
SendCommMessage(0, TCommThreadParams.Create.SetParam('status', 'started'));

for i := 0 to 40 do
begin
sleep(50);

SendStatusMessage(format('Thread: %s, i = %d', [Name, i]), 1);

if Terminated then
Break;

sleep(50);

SendProgressMessage(Integer(Self), i, 40, FALSE);
end;

if Terminated then
SendCommMessage(0, TCommThreadParams.Create.SetParam('status', 'terminated'))
else
SendCommMessage(0, TCommThreadParams.Create.SetParam('status', 'finished'));
end;

{ TfrmMain }

procedure TfrmMain.btnStopClick(Sender: TObject);
begin
FCommThreadComponent.Stop;
end;

procedure TfrmMain.Button3Click(Sender: TObject);
var
i: Integer;
begin
for i := 0 to 29 do
FCommThreadComponent.NewThread
.SetParam('input_param1', 'test_value')
.Start;
end;

procedure TfrmMain.Button4Click(Sender: TObject);
begin
FCommThreadComponent.NewThread
.SetParam('input_param1', 'test_value')
.Start;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
FCommThreadComponent := TStatusCommThreadDispatch.Create(Self);

// Add the event handlers
FCommThreadComponent.OnStateChange := OnStateChange;
FCommThreadComponent.OnReceiveThreadMessage := OnReceiveThreadMessage;
FCommThreadComponent.OnStatus := OnStatus;
FCommThreadComponent.OnProgress := OnProgress;

// Set the thread class
FCommThreadComponent.CommThreadClass := TMyCommThread;
end;

procedure TfrmMain.OnProgress(Source, Sender: TObject; const ID: String; Progress, ProgressMax: Integer);
begin
With lvLog.Items.Add do
begin
Caption := '-';

SubItems.Add(format(StrStatusIDDProgre, [Id, Progress, ProgressMax]));
end;
end;

procedure TfrmMain.OnReceiveThreadMessage(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
if MessageID = 0 then
With lvLog.Items.Add do
begin
Caption := IntToStr(MessageId);

SubItems.Add(CommThreadParams.GetParam('status'));
end;
end;

procedure TfrmMain.UpdateStatusBar;
begin
StatusBar1.SimpleText := format(StrActiveThreadsD, [FCommThreadComponent.ActiveThreadCount, FCommThreadComponent.StateText]);
end;

procedure TfrmMain.OnStateChange(Sender: TObject; State: TCommThreadDispatchState);
begin
With lvLog.Items.Add do
begin
case State of
ctsIdle: Caption := StrIdle;
ctsActive: Caption := StrActive;
ctsTerminating: Caption := StrTerminating;
end;
end;
end;

procedure TfrmMain.OnStatus(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer);
begin
With lvLog.Items.Add do
begin
Caption := IntToStr(StatusType);

SubItems.Add(StatusText);
end;
end;

procedure TfrmMain.tmrUpdateStatusBarTimer(Sender: TObject);
begin
UpdateStatusBar;
end;

end.

Test app (.dfm)

object frmMain: TfrmMain
Left = 0
Top = 0
Caption = 'CommThread Test'
ClientHeight = 290
ClientWidth = 557
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
AlignWithMargins = True
Left = 3
Top = 3
Width = 97
Height = 265
Margins.Right = 0
Align = alLeft
BevelOuter = bvNone
TabOrder = 0
object btnStop: TButton
AlignWithMargins = True
Left = 0
Top = 60
Width = 97
Height = 25
Margins.Left = 0
Margins.Top = 10
Margins.Right = 0
Margins.Bottom = 0
Align = alTop
Caption = 'Stop'
TabOrder = 2
OnClick = btnStopClick
end
object btnNewThread: TButton
Left = 0
Top = 0
Width = 97
Height = 25
Align = alTop
Caption = 'New Thread'
TabOrder = 0
OnClick = Button4Click
end
object btn30NewThreads: TButton
Left = 0
Top = 25
Width = 97
Height = 25
Align = alTop
Caption = '30 New Threads'
TabOrder = 1
OnClick = Button3Click
end
end
object lvLog: TListView
AlignWithMargins = True
Left = 103
Top = 3
Width = 451
Height = 265
Align = alClient
Columns = <
item
Caption = 'Message ID'
Width = 70
end
item
AutoSize = True
Caption = 'Info'
end>
ReadOnly = True
RowSelect = True
TabOrder = 1
ViewStyle = vsReport
end
object StatusBar1: TStatusBar
Left = 0
Top = 271
Width = 557
Height = 19
Panels = <>
SimplePanel = True
end
object tmrUpdateStatusBar: TTimer
Interval = 200
OnTimer = tmrUpdateStatusBarTimer
Left = 272
Top = 152
end
end