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

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

在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,,,,,,,hInstance,nil);

    SetWindowLong(FMSGWin, GWL_WNDPROC, Longint(MakeObjectInstance(MSGWinProc)));

{$ELSE}

    PeekMessage(Msg,,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,,,,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,,,);

                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 <>  then

        begin

            aEvent := FEventList.Items[];

            if aEvent <> nil then

            begin

                SetEvent(aEvent^);

                CloseHandle(aEvent^);

                Dispose(aEvent);

            end;

            FEventList.Delete();

        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,,,,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();

end;

{//////////////////////////////////////////////////////////////////////////////}

procedure TMsgThread.QuitThread;

begin

    {$IFDEF USE_WINDOW_MESSAGE}

    PostMessage(FMSGWin,WM_QUIT,,);

    {$ELSE}

    PostThreadMessage(ThreadID,WM_QUIT,,);

    {$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,,);

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, ) = WAIT_TIMEOUT do

        begin

            Application.ProcessMessages;

            if GetTickCount > (xStart + ) then

            begin

                TerminateThread(Handle, );

                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 =  ) : 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 := ;

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, , , , , ,  , hInstance, nil );

  SetWindowLong( SyncWindow, GWL_WNDPROC,  Longint( MakeObjectInstance( SyncWindowProc ) ) );

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

  // Create Thread

  m_hThread := CreateThread( nil, , @msgThdInitialThreadProc, Self, , threadid );

  if m_hThread =  then

    raise EMsgThreadErr.Create( '不能创建线程。' );

  // Wait until thread Message Loop started

  WaitForSingleObject( FWaitHandle, INFINITE );

end;

{ ------------------------------------------------------------------------------ }

destructor TMsgThread.destroy;

begin

  if m_hThread <>  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, , , , , ,  , hInstance, nil );

  SetWindowLong( FMSGWin, GWL_WNDPROC,  Longint( MakeObjectInstance( MSGWinProc ) ) );

{$ELSE}

  PeekMessage( Msg, , 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, , , , 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, , ,  );

        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 <>  then

    begin

      aEvent := FEventList.Items[  ];

      if aEvent <> nil then

      begin

        SetEvent( aEvent^ );

        CloseHandle( aEvent^ );

        Dispose( aEvent );

        WaitForSingleObject( fSendMsgComp, INFINITE );

      end;

      FEventList.Delete(  );

    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, , , , 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(  );

end;

{ ////////////////////////////////////////////////////////////////////////////// }

function TMsgThread.ThreadExists : BOOL;

begin

  if m_hThread =  then

    Result := False

  else

    Result := True;

end;

{ ------------------------------------------------------------------------------ }

procedure TMsgThread.QuitThread;

begin

{$IFDEF USE_WINDOW_MESSAGE}

  PostMessage( FMSGWin, WM_QUIT, ,  );

{$ELSE}

  PostThreadMessage( threadid, WM_QUIT, ,  );

{$ENDIF}

end;

{ ------------------------------------------------------------------------------ }

procedure TMsgThread.SetDoLoop( const Value : Boolean );

begin

  if Value = fDoLoop then

    Exit;

  fDoLoop := Value;

  if fDoLoop then

    PostMsg( WM_USER, ,  );

end;

{ ------------------------------------------------------------------------------ }

function TMsgThread.WaitTimeOut( timeout : DWORD ) : Longword;

var

  xStart : Cardinal;

  H : THandle;

begin

  H := m_hThread;

  xStart := GetTickCount;

  while WaitForSingleObject( H,  ) = WAIT_TIMEOUT do

  begin

    Application.ProcessMessages;

    if GetTickCount > ( xStart + timeout ) then

    begin

      TerminateThread( H,  );

      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( , H, False, INFINITE, QS_SENDMESSAGE )

      = WAIT_OBJECT_ +  do

      PeekMessage( Msg, , , , 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, , Longint( Self ) );

end;

{ ------------------------------------------------------------------------------ }

procedure TMsgThread.SyncWindowProc( var Message : TMessage );

begin

  case message.Msg of

    NM_EXECPROC :

      with TMsgThread( message.lParam ) do

      begin

        message.Result := ;

        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 = ;

   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

TMsgThread, TCommThread -- 在delphi线程中实现消息循环的更多相关文章

TMsgThread, TCommThread -- 在delphi线程中实现消息循环（105篇博客，好多研究消息的文章）
在delphi线程中实现消息循环在delphi线程中实现消息循环 Delphi的TThread类使用很方便,但是有时候我们需要在线程类中使用消息循环,delphi没有提供. 花了两天的事件研究了 ...
TCommThread -- 在delphi线程中实现消息循环
http://www.techques.com/question/1-4073197/How-do-I-send-and-handle-message-between-TService-parent- ...
Looper.loop() android线程中的消息循环
Looper用于封装了android线程中的消息循环,默认情况下一个线程是不存在消息循环(message loop)的,需要调用Looper.prepare()来给线程创建一个消息循环,调用Loope ...
安卓中的消息循环机制Handler及Looper详解
我们知道安卓中的UI线程不是线程安全的,我们不能在UI线程中进行耗时操作,通常我们的做法是开启一个子线程在子线程中处理耗时操作,但是安卓规定不允许在子线程中进行UI的更新操作,通常我们会通过Handl ...
delphi XE7 中的消息
在delphi XE7的程序开发中,消息机制保证进程间的通信. 在程序中,消息来自: 1)系统: 通知你的程序用户输入,涂画以及其他的系统范围的事件: 2)你的程序:不同的程序部分之间的通信信息. ...
【转载】Delphi7从子线程中发送消息到主线程触发事件执行
在对数据库的操作时,有时要用一个子线程来进行后台的数据操作.比如说数据备份,转档什么的.在主窗口还能同是进行其它操作.而有时后台每处理一个数据文件,要向主窗口发送消息,让主窗口实时显示处理进度在窗口上 ...
Chrome中的消息循环
主要是自己做个学习笔记吧,我经验也不是很丰富,以前学习多线程的时候就感觉写多线程程序很麻烦.主要是线程之间要通信,要切线程,要同步,各种麻烦.我本身的工作经历决定了也没有太多的工作经验,所以chrom ...
Windows 消息循环(2) - WPF中的消息循环
接上文: Windows 消息循环(1) - 概览 win32/MFC/WinForm/WPF 都依靠消息循环驱动,让程序跑起来. 本文介绍 WPF 中是如何使用消息循环来驱动程序的. 4 消息循环在 ...
事件循环和线程没有必然关系（就像Windows子线程默认没有消息循环一样），模态对话框和事件循环也没有必然关系（QWidget直接就可以）
周末天冷,索性把电脑抱到床上上网,这几天看了 dbzhang800 博客关于 Qt 事件循环的几篇 Blog,发现自己对 Qt 的事件循环有不少误解.从来只看到现象,这次借 dbzhang800 的博 ...

随机推荐

设计模式-单键(Singleton)
[摘要] 在软件系统中,经常有这样一些特殊的类,必须保证它们在系统中只存在一个实例,才能确保它们的逻辑正确性.以及良好的效率. 如何绕过常规的构造器,提供一种机制来保证一个类只有一个实例? 这应该 ...
清除Xcode缓存和存档文件
XCode4.2 finder中找到 /Users/Library/Developer/Xcode (注:Library资源库是隐藏的文件夹) 里面有DerivedData和Snaps ...
堪称最好的A*算法
原文地址:http://theory.stanford.edu/~amitp/GameProgramming/ 相关链接:http://www-cs-students.stanford.edu/%7E ...
C#-gdi绘图,双缓冲绘图,Paint事件的触发
一. 画面闪烁问题与双缓冲技术 1.1 导致画面闪烁的关键原因分析: 1 绘制窗口由于大小位置状态改变进行重绘操作时绘图窗口内容或大小每改变一次,都要调用Paint事件进行重绘操作,该操作会使画面 ...
LoadRunner学习记录--安装遇到的问题一
安装过程中的出现了此计算机上缺少vc2005_sp1_with_atl_fix_redist 需要到这个目录下lrunner\En\prerequisites\vc2005_sp1_redist\ 手 ...
ANSI
为了扩充ASCII编码,以用于显示本国的语言,不同的国家和地区制定了不同的编码标准,由此产生了GB2312.BIG5.JIS等各自的编码标准.这些使用两个字节来代表一个字符的各种汉字延伸编码方式被称为 ...
Python的pep8（代码规范）
Python的pep8-代码规范 1. 代码布局设计 1.1 缩进 A. 使用四个空格来进行缩进 B. 换行的时候可以使用反斜杠,最好的方法是使用园括号,在使用反斜杠的时候,在反斜 ...
数往知来 AJAX Ajax增删改查<十九>
=================================================客户端================================================ ...
算法：最大子数组own
转载标明出处:http://i.cnblogs.com/EditPosts.aspx?postid=4726782&update=1 暴力法: // maxValue.cpp : 定义控制台应 ...
关于Windows API、CRT和STL二三事
1.本文编写目的本文是为了帮助一些人弄清一些关于Windows API, C运行时程序库(CRT), 和标准C++库(STL)的基本概念.有很多人甚至是有经验的程序员在这些概念上是含糊不清的甚 ...

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

在delphi线程中实现消息循环

TMsgThread, TCommThread -- 在delphi线程中实现消息循环的更多相关文章

随机推荐

热门专题