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

原作者: [db:作者] 来自: [db:来源] 收藏邀请

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

在delphi线程中实现消息循环

在delphi线程中实现消息循环

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

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

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

{-----------------------------------------------------------------------------
Unit Name: uMsgThread
Author:    xwing
eMail :    [email protected] ; MSN : [email protected]
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 :    [email protected] ; MSN : [email protected]
  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}<