TMsgThread, TCommThread -- 在delphi线程中实现消息循环(105篇博客,好多研究消息的文章)

Posted 朝闻道

tags:

篇首语:本文由小常识网(cha138.com)小编为大家整理,主要介绍了TMsgThread, TCommThread -- 在delphi线程中实现消息循环(105篇博客,好多研究消息的文章)相关的知识,希望对你有一定的参考价值。

在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:

复制代码
  1 unit Threading.CommThread;
  2 
  3 interface
  4 
  5 uses
  6   Classes, SysUtils, ExtCtrls, SyncObjs, Generics.Collections, DateUtils;
  7 
  8 const
  9   CTID_USER = 1000;
 10   PRM_USER = 1000;
 11 
 12   CTID_STATUS = 1;
 13   CTID_PROGRESS = 2;
 14 
 15 type
 16   TThreadParams = class(TDictionary<String, Variant>);
 17   TThreadObjects = class(TDictionary<String, TObject>);
 18 
 19   TCommThreadParams = class(TObject)
 20   private
 21     FThreadParams: TThreadParams;
 22     FThreadObjects: TThreadObjects;
 23   public
 24     constructor Create;
 25     destructor Destroy; override;
 26 
 27     procedure Clear;
 28 
 29     function GetParam(const ParamName: String): Variant;
 30     function SetParam(const ParamName: String; ParamValue: Variant): TCommThreadParams;
 31     function GetObject(const ObjectName: String): TObject;
 32     function SetObject(const ObjectName: String; Obj: TObject): TCommThreadParams;
 33   end;
 34 
 35   TCommQueueItem = class(TObject)
 36   private
 37     FSender: TObject;
 38     FMessageId: Integer;
 39     FCommThreadParams: TCommThreadParams;
 40   public
 41     destructor Destroy; override;
 42 
 43     property Sender: TObject read FSender write FSender;
 44     property MessageId: Integer read FMessageId write FMessageId;
 45     property CommThreadParams: TCommThreadParams read FCommThreadParams write FCommThreadParams;
 46   end;
 47 
 48   TCommQueue = class(TQueue<TCommQueueItem>);
 49 
 50   ICommDispatchReceiver = interface
 51     [\'{A4E2C9D1-E4E8-497D-A9BF-FAFE2D3A7C49}\']
 52     procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
 53     procedure CommThreadTerminated(Sender: TObject);
 54     function Cancelled: Boolean;
 55   end;
 56 
 57   TCommThread = class(TThread)
 58   protected
 59     FCommThreadParams: TCommThreadParams;
 60     FCommDispatchReceiver: ICommDispatchReceiver;
 61     FName: String;
 62     FProgressFrequency: Integer;
 63     FNextSendTime: TDateTime;
 64 
 65     procedure SendStatusMessage(const StatusText: String; StatusType: Integer = 0); virtual;
 66     procedure SendProgressMessage(ProgressID: Int64; Progress, ProgressMax: Integer; AlwaysSend: Boolean = TRUE); virtual;
 67   public
 68     constructor Create(CommDispatchReceiver: TObject); reintroduce; virtual;
 69     destructor Destroy; override;
 70 
 71     function SetParam(const ParamName: String; ParamValue: Variant): TCommThread;
 72     function GetParam(const ParamName: String): Variant;
 73     function SetObject(const ObjectName: String; Obj: TObject): TCommThread;
 74     function GetObject(const ObjectName: String): TObject;
 75     procedure SendCommMessage(MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;
 76 
 77     property Name: String read FName;
 78   end;
 79 
 80   TCommThreadClass = Class of TCommThread;
 81 
 82   TCommThreadQueue = class(TObjectList<TCommThread>);
 83 
 84   TCommThreadDispatchState = (
 85     ctsIdle,
 86     ctsActive,
 87     ctsTerminating
 88   );
 89 
 90   TOnReceiveThreadMessage = procedure(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams) of object;
 91   TOnStateChange = procedure(Sender: TObject; State: TCommThreadDispatchState) of object;
 92   TOnStatus = procedure(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer) of object;
 93   TOnProgress = procedure(Source, Sender: TObject; const ID: String; Progress, ProgressMax: Integer) of object;
 94 
 95   TBaseCommThreadDispatch = class(TComponent, ICommDispatchReceiver)
 96   private
 97     FProcessQueueTimer: TTimer;
 98     FCSReceiveMessage: TCriticalSection;
 99     FCSCommThreads: TCriticalSection;
100     FCommQueue: TCommQueue;
101     FActiveThreads: TList;
102     FCommThreadClass: TCommThreadClass;
103     FCommThreadDispatchState: TCommThreadDispatchState;
104 
105     function CreateThread(const ThreadName: String = \'\'): TCommThread;
106     function GetActiveThreadCount: Integer;
107     function GetStateText: String;
108   protected
109     FOnReceiveThreadMessage: TOnReceiveThreadMessage;
110     FOnStateChange: TOnStateChange;
111     FOnStatus: TOnStatus;
112     FOnProgress: TOnProgress;
113     FManualMessageQueue: Boolean;
114     FProgressFrequency: Integer;
115 
116     procedure SetManualMessageQueue(const Value: Boolean);
117     procedure SetProcessQueueTimerInterval(const Value: Integer);
118     procedure SetCommThreadDispatchState(const Value: TCommThreadDispatchState);
119     procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
120     procedure OnProcessQueueTimer(Sender: TObject);
121     function GetProcessQueueTimerInterval: Integer;
122 
123     procedure CommThreadTerminated(Sender: TObject); virtual;
124     function Finished: Boolean; virtual;
125 
126     procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;
127     procedure DoOnStateChange; virtual;
128 
129     procedure TerminateActiveThreads;
130 
131     property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
132     property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
133     property OnStatus: TOnStatus read FOnStatus write FOnStatus;
134     property OnProgress: TOnProgress read FOnProgress write FOnProgress;
135 
136     property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
137     property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
138     property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
139     property CommThreadDispatchState: TCommThreadDispatchState read FCommThreadDispatchState write SetCommThreadDispatchState;
140   public
141     constructor Create(AOwner: TComponent); override;
142     destructor Destroy; override;
143 
144     function NewThread(const ThreadName: String = \'\'): TCommThread; virtual;
145     procedure ProcessMessageQueue; virtual;
146     procedure Stop; virtual;
147     function State: TCommThreadDispatchState;
148     function Cancelled: Boolean;
149 
150     property ActiveThreadCount: Integer read GetActiveThreadCount;
151     property StateText: String read GetStateText;
152 
153     property CommThreadClass: TCommThreadClass read FCommThreadClass write FCommThreadClass;
154   end;
155 
156   TCommThreadDispatch = class(TBaseCommThreadDispatch)
157   published
158     property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
159     property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
160 
161     property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
162     property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
163     property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
164   end;
165 
166   TBaseStatusCommThreadDispatch = class(TBaseCommThreadDispatch)
167   protected
168     FOnStatus: TOnStatus;
169     FOnProgress: TOnProgress;
170 
171     procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); override;
172 
173     procedure DoOnStatus(Sender: TObject;const ID: String; const StatusText: String; StatusType: Integer); virtual;
174     procedure DoOnProgress(Sender: TObject; const ID: String; Progress, ProgressMax: Integer); virtual;
175 
176     property OnStatus: TOnStatus read FOnStatus write FOnStatus;
177     property OnProgress: TOnProgress read FOnProgress write FOnProgress;
178   end;
179 
180   TStatusCommThreadDispatch = class(TBaseStatusCommThreadDispatch)
181   published
182     property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
183     property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
184     property OnStatus: TOnStatus read FOnStatus write FOnStatus;
185     property OnProgress: TOnProgress read FOnProgress write FOnProgress;
186 
187     property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
188     property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
189     property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
190   end;
191 
192 implementation
193 
194 const
195   PRM_STATUS_TEXT = \'Status\';
196   PRM_STATUS_TYPE = \'Type\';
197   PRM_PROGRESS_ID = \'ProgressID\';
198   PRM_PROGRESS = \'Progess\';
199   PRM_PROGRESS_MAX = \'ProgressMax\';
200 
201 resourcestring
202   StrCommReceiverMustSupportInterface = \'CommDispatchReceiver must support ICommDispatchReceiver interface\';
203   StrSenderMustBeATCommThread = \'Sender must be a TCommThread\';
204   StrUnableToFindTerminatedThread = \'Unable to find the terminated thread\';
205   StrIdle = \'Idle\';
206   StrTerminating = \'Terminating\';
207   StrActive = \'Active\';
208 
209 { TCommThread }
210 
211 constructor TCommThread.Create(CommDispatchReceiver: TObject);
212 begin
213   Assert(Supports(CommDispatchReceiver, ICommDispatchReceiver, FCommDispatchReceiver), StrCommReceiverMustSupportInterface);
214 
215   inherited Create(TRUE);
216 
217   FCommThreadParams := TCommThreadParams.Create;
218 end;
219 
220 destructor TCommThread.Destroy;
221 begin
222   FCommDispatchReceiver.CommThreadTerminated(Self);
223 
224   FreeAndNil(FCommThreadParams);
225 
226   inherited;
227 end;
228 
229 function TCommThread.GetObject(const ObjectName: String): TObject;
230 begin
231   Result := FCommThreadParams.GetObject(ObjectName);
232 end;
233 
234 function TCommThread.GetParam(const ParamName: String): Variant;
235 begin
236   Result := FCommThreadParams.GetParam(ParamName);
237 end;
238 
239 procedure TCommThread.SendCommMessage(MessageId: Integer;
240   CommThreadParams: TCommThreadParams);
241 begin
242   FCommDispatchReceiver.QueueMessage(Self, MessageId, CommThreadParams);
243 end;
244 
245 procedure TCommThread.SendProgressMessage(ProgressID: Int64; Progress,
246   ProgressMax: Integer; AlwaysSend: Boolean);
247 begin
248   if (AlwaysSend) or (now > FNextSendTime) then
249   begin
250     // Send a status message to the comm receiver
251     SendCommMessage(CTID_PROGRESS, TCommThreadParams.Create
252       .SetParam(PRM_PROGRESS_ID, ProgressID)
253       .SetParam(PRM_PROGRESS, Progress)
254       .SetParam(PRM_PROGRESS_MAX, ProgressMax));
255 
256     if not AlwaysSend then
257       FNextSendTime := now + (FProgressFrequency * OneMillisecond);
258   end;
259 end;
260 
261 procedure TCommThread.SendStatusMessage(const StatusText: String;
262   StatusType: Integer);
263 begin
264   // Send a status message to the comm receiver
265   SendCommMessage(CTID_STATUS, TCommThreadParams.Create
266     .SetParam(PRM_STATUS_TEXT, StatusText)
267     .SetParam(PRM_STATUS_TYPE, StatusType));
268 end;
269 
270 function TCommThread.SetObject(const ObjectName: String;
271   Obj: TObject): TCommThread;
272 begin
273   Result := Self;
274 
275   FCommThreadParams.SetObject(ObjectName, Obj);
276 end;
277 
278 function TCommThread.SetParam(const ParamName: String;
279   ParamValue: Variant): TCommThread;
280 begin
281   Result := Self;
282 
283   FCommThreadParams.SetParam(ParamName, ParamValue);
284 end;
285 
286 
287 { TCommThreadDispatch }
288 
289 function TBaseCommThreadDispatch.Cancelled: Boolean;
290 begin
291   Result := State = ctsTerminating;
292 end;
293 
294 procedure TBaseCommThreadDispatch.CommThreadTerminated(Sender: TObject);
295 var
296   idx: Integer;
297 begin
298   FCSCommThreads.Enter;
299   try
300     Assert(Sender is TCommThread, StrSenderMustBeATCommThread);
301 
302     // Find the thread in the active thread list
303     idx := FActiveThreads.IndexOf(Sender);
304 
305     Assert(idx <> -1, StrUnableToFindTerminatedThread);
306 
307     // if we find it, remove it (we should always find it)
308     FActiveThreads.Delete(idx);
309   finally
310     FCSCommThreads.Leave;
311   end;
312 end;
313 
314 constructor TBaseCommThreadDispatch.Create(AOwner: TComponent);
315 begin
316   inherited;
317 
318   FCommThreadClass := TCommThread;
319 
320   FProcessQueueTimer := TTimer.Create(nil);
321   FProcessQueueTimer.Enabled := FALSE;
322   FProcessQueueTimer.Interval := 5;
323   FProcessQueueTimer.OnTimer := OnProcessQueueTimer;
324   FProgressFrequency := 200;
325 
326   FCommQueue := TCommQueue.Create;
327 
328   FActiveThreads := TList.Create;
329 
330   FCSReceiveMessage := TCriticalSection.Create;
331   FCSCommThreads := TCriticalSection.Create;
332 end;
333 
334 destructor TBaseCommThreadDispatch.Destroy;
335 begin
336   // Stop the queue timer
337   FProcessQueueTimer.Enabled := FALSE;
338 
339   TerminateActiveThreads;
340 
341   // Pump the queue while there are active threads
342   while CommThreadDispatchState <> ctsIdle do
343   begin
344     ProcessMessageQueue;
345 
346     sleep(10);
347   end;
348 
349   // Free everything
350   FreeAndNil(FProcessQueueTimer);
351   FreeAndNil(FCommQueue);
352   FreeAndNil(FCSReceiveMessage);
353   FreeAndNil(FCSCommThreads);
354   FreeAndNil(FActiveThreads);
355 
356   inherited;
357 end;
358 
359 procedure TBaseCommThreadDispatch.DoOnReceiveThreadMessage(Sender: TObject;
360   MessageId: Integer; CommThreadParams: TCommThreadParams);
361 begin
362   // Don\'t send the messages if we\'re being destroyed
363   if not (csDestroying in ComponentState) then
364   begin
365     if Assigned(FOnReceiveThreadMessage) then
366       FOnReceiveThreadMessage(Self, Sender, MessageId, CommThreadParams);
367   end;
368 end;
369 
370 procedure TBaseCommThreadDispatch.DoOnStateChange;
371 begin
372   if (Assigned(FOnStateChange)) and (not (csDestroying in ComponentState)) then
373     FOnStateChange(Self, FCommThreadDispatchState);
374 end;
375 
376 function TBaseCommThreadDispatch.GetActiveThreadCount: Integer;
377 begin
378   Result := FActiveThreads.Count;
379 end;
380 
381 function TBaseCommThreadDispatch.GetProcessQueueTimerInterval: Integer;
382 begin
383   Result := FProcessQueueTimer.Interval;
384 end;
385 
386 
387 function TBaseCommThreadDispatch.GetStateText: String;
388 begin
389   case State of
390     ctsIdle: Result := StrIdle;
391     ctsTerminating: Result := StrTerminating;
392     ctsActive: Result := StrActive;
393   end;
394 end;
395 
396 function TBaseCommThreadDispatch.NewThread(const ThreadName: String): TCommThread;
397 begin
398   if FCommThreadDispatchState = ctsTerminating then
399     Result := nil
400   else
401   begin
402     // Make sure we\'re active
403     if CommThreadDispatchState = ctsIdle then
404       CommThreadDispatchState := ctsActive;
405 
406     Result := CreateThread(ThreadName);
407 
408     FActiveThreads.Add(Result);
409 
410     if ThreadName = \'\' then
411       Result.FName := IntToStr(Integer(Result))
412     else
413       Result.FName := ThreadName;
414 
415     Result.FProgressFrequency := FProgressFrequency;
416   end;
417 end;
418 
419 function TBaseCommThreadDispatch.CreateThread(
420   const ThreadName: String): TCommThread;
421 begin
422   Result := FCommThreadClass.Create(Self);
423 
424   Result.FreeOnTerminate := TRUE;
425 end;
426 
427 procedure TBaseCommThreadDispatch.OnProcessQueueTimer(Sender: TObject);
428 begin
429   ProcessMessageQueue;
430 end;
431 
432 procedure TBaseCommThreadDispatch.ProcessMessageQueue;
433 var
434   CommQueueItem: TCommQueueItem;
435 begin
436   if FCommThreadDispatchState in [ctsActive, ctsTerminating] then
437   begin
438     if FCommQueue.Count > 0 then
439     begin
440       FCSReceiveMessage.Enter;
441       try
442         CommQueueItem := FCommQueue.Dequeue;
443 
444         while Assigned(CommQueueItem) do
445         begin
446           try
447             DoOnReceiveThreadMessage(CommQueueItem.Sender, CommQueueItem.MessageId, CommQueueItem.CommThreadParams);
448           finally
449             FreeAndNil(CommQueueItem);
450           end;
451 
452           if FCommQueue.Count > 0 then
453             CommQueueItem := FCommQueue.Dequeue;
454         end;
455       finally
456         FCSReceiveMessage.Leave
457       end;
458     end;
459 
460     if Finished then
461     begin
462       FCommThreadDispatchState := ctsIdle;
463 
464       DoOnStateChange;
465     end;
466   end;
467 end;
468 
469 function TBaseCommThreadDispatch.Finished: Boolean;
470 begin
471   Result := FActiveThreads.Count = 0;
472 end;
473 
474 procedure TBaseCommThreadDispatch.QueueMessage(Sender: TObject; MessageId: Integer;
475   CommThreadParams: TCommThreadParams);
476 var
477   CommQueueItem: TCommQueueItem;
478 begin
479   FCSReceiveMessage.Enter;
480   try
481     CommQueueItem := TCommQueueItem.Create;
482     CommQueueItem.Sender := Sender;
483     CommQueueItem.MessageId := MessageId;
484     CommQueueItem.CommThreadParams := CommThreadParams;
485 
486     FCommQueue.Enqueue(CommQueueItem);
487   finally
488     FCSReceiveMessage.Leave
489   end;
490 end;
491 
492 procedure TBaseCommThreadDispatch.SetCommThreadDispatchState(
493   const Value: TCommThreadDispatchState);
494 begin
495   if FCommThreadDispatchState <> ctsTerminating then
496   begin
497     if Value = ctsActive then
498     begin
499       if not FManualMessageQueue then
500         FProcessQueueTimer.Enabled := TRUE;
501     end
502     else
503       TerminateActiveThreads;
504   end;
505 
506   FCommThreadDispatchState := Value;
507 
508   DoOnStateChange;
509 end;
510 
511 procedure TBaseCommThreadDispatch.SetManualMessageQueue(const Value: Boolean);
512 begin
513   FManualMessageQueue := Value;
514 end;
515 
516 procedure TBaseCommThreadDispatch.SetProcessQueueTimerInterval(const Value: Integer);
517 begin
518   FProcessQueueTimer.Interval := Value;
519 end;
520 
521 function TBaseCommThreadDispatch.State: TCommThreadDispatchState;
522 begin
523   Result := FCommThreadDispatchState;
524 end;
525 
526 procedure TBaseCommThreadDispatch.Stop;
527 begin
528   if CommThreadDispatchState = ctsActive then
529     TerminateActiveThreads;
530 end;
531 
532 procedure TBaseCommThreadDispatch.TerminateActiveThreads;
533 var
534   i: Integer;
535 begin
536   if FCommThreadDispatchState = ctsActive then
537   begin
538     // Lock threads
539     FCSCommThreads.Acquire;
540     try
541       FCommThreadDispatchState := ctsTerminating;
542 
543       DoOnStateChange;
544 
545       // Terminate each thread in turn
546       for i := 0 to pred(FActiveThreads.Count) do
547         TCommThread(FActiveThreads[i]).Terminate;
548     finally
549       FCSCommThreads.Release;
550     end;
551   end;
552 end;
553 
554 
555 { TCommThreadParams }
556 
557 procedure TCommThreadParams.Clear;
558 begin
559   FThreadParams.Clear;
560   FThreadObjects.Clear;
561 end;
562 
563 constructor TCommThreadParams.Create;
564 begin
565   FThreadParams := TThreadParams.Create;
566   FThreadObjects := TThreadObjects.Create;
567 end;
568 
569 destructor TCommThreadParams.Destroy;
570 begin
571   FreeAndNil(FThreadParams);
572   FreeAndNil(FThreadObjects);
573 
574   inherited;
575 end;
576 
577 function TCommThreadParams.GetObject(const ObjectName: String): TObject;
578 begin
579   Result := FThreadObjects.Items[ObjectName];
580 end;
581 
582 function TCommThreadParams.GetParam(const ParamName: String): Variant;
583 begin
584   Result := FThreadParams.Items[ParamName];
585 end;
586 
587 function TCommThreadParams.SetObject(const ObjectName: String;
588   Obj: TObject): TCommThreadParams;
589 begin
590   FThreadObjects.AddOrSetValue(ObjectName, Obj);
591 
592   Result := Self;
593 end;
594 
595 function TCommThreadParams.SetParam(const ParamName: String;
596   ParamValue: Variant): TCommThreadParams;
597 begin
598   FThreadParams.AddOrSetValue(ParamName, ParamValue);
599 
600   Result := Self;
601 end;
602 
603 { TCommQueueItem }
604 
605 destructor TCommQueueItem.Destroy;
606 begin
607   if Assigned(FCommThreadParams) then
608     FreeAndNil(FCommThreadParams);
609 
610   inherited;
611 end;
612 
613 
614 { TBaseStatusCommThreadDispatch }
615 
616 procedure TBaseStatusCommThreadDispatch.DoOnReceiveThreadMessage(
617   Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
618 begin
619   inherited;
620 
621   case MessageId of
622     // Status Message
623     CTID_STATUS: DoOnStatus(Sender,
624                             Name,
625                             CommThreadParams.GetParam(PRM_STATUS_TEXT),
626                             CommThreadParams.GetParam(PRM_STATUS_TYPE));
627     // Progress Message
628     CTID_PROGRESS: DoOnProgress(Sender,
629                                 CommThreadParams.GetParam(PRM_PROGRESS_ID),
630                                 CommThreadParams.GetParam(PRM_PROGRESS),
631                                 CommThreadParams.GetParam(PRM_PROGRESS_MAX));
632   end;
633 end;
634 
635 procedure TBaseStatusCommThreadDispatch.DoOnStatus(Sender: TObject; const ID,
636   StatusText: String; StatusType: Integer);
637 begin
638   if (not (csDestroying in ComponentState)) and (Assigned(FOnStatus)) then
639     FOnStatus(Self, Sender, ID, StatusText, StatusType);
640 end;
641 
642 procedure TBaseStatusCommThreadDispatch.DoOnProgress(Sender: TObject;
643   const ID: String; Progress, ProgressMax: Integer);
644 begin
645   if not (csDestroying in ComponentState) and (Assigned(FOnProgress)) then
646     FOnProgress(Self, Sender, ID, Progress, ProgressMax);
647 end;
648 
649 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
复制代码

http://www.cnblogs.com/shangdawei/p/4015682.html

以上是关于TMsgThread, TCommThread -- 在delphi线程中实现消息循环(105篇博客,好多研究消息的文章)的主要内容,如果未能解决你的问题,请参考以下文章