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

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 = ;
   PRM_USER = ;
 
   CTID_STATUS = ;
   CTID_PROGRESS = ;
 
 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 = ); 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 <> -, 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 := ;
   FProcessQueueTimer.OnTimer := OnProcessQueueTimer;
   FProgressFrequency := ;
 
   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();
   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 >  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 >  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 = ;
 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 :=  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', '')
    .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'); //
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(, TCommThreadParams.Create.SetParam('status', 'started'));
 
  for i :=  to  do
  begin
    sleep();
 
    SendStatusMessage(format('Thread: %s, i = %d', [Name, i]), );
 
    if Terminated then
      Break;
 
    sleep();
 
    SendProgressMessage(Integer(Self), i, , FALSE);
  end;
 
  if Terminated then
    SendCommMessage(, TCommThreadParams.Create.SetParam('status', 'terminated'))
  else
    SendCommMessage(, 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 :=  to  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 =  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 =
  Top =
  Caption = 'CommThread Test'
  ClientHeight =
  ClientWidth =
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch =
  TextHeight =
  object Panel1: TPanel
    AlignWithMargins = True
    Left =
    Top =
    Width =
    Height =
    Margins.Right =
    Align = alLeft
    BevelOuter = bvNone
    TabOrder =
    object btnStop: TButton
      AlignWithMargins = True
      Left =
      Top =
      Width =
      Height =
      Margins.Left =
      Margins.Top =
      Margins.Right =
      Margins.Bottom =
      Align = alTop
      Caption = 'Stop'
      TabOrder =
      OnClick = btnStopClick
    end
    object btnNewThread: TButton
      Left =
      Top =
      Width =
      Height =
      Align = alTop
      Caption = 'New Thread'
      TabOrder =
      OnClick = Button4Click
    end
    object btn30NewThreads: TButton
      Left =
      Top =
      Width =
      Height =
      Align = alTop
      Caption = '30 New Threads'
      TabOrder =
      OnClick = Button3Click
    end
  end
  object lvLog: TListView
    AlignWithMargins = True
    Left =
    Top =
    Width =
    Height =
    Align = alClient
    Columns = <
      item
        Caption = 'Message ID'
        Width =
      end
      item
        AutoSize = True
        Caption = 'Info'
      end>
    ReadOnly = True
    RowSelect = True
    TabOrder =
    ViewStyle = vsReport
  end
  object StatusBar1: TStatusBar
    Left =
    Top =
    Width =
    Height =
    Panels = <>
    SimplePanel = True
  end
  object tmrUpdateStatusBar: TTimer
    Interval =
    OnTimer = tmrUpdateStatusBarTimer
    Left =
    Top =
  end
end