在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属性可以设定线程是否循环(不阻塞等待消息),这样派生类线程在循环做一些其他事情的同时还可以接受消息. 例如:派生类里面循环发送缓冲区的数据,还可以响应其他线程发送过来的消息(如停止,启动,退出,等等)


我一般在线程中需要使用消息循环时是直接用
if (PeekMessage(msg,0,0,0,PM_REMOVE)) then
 begin
   // 这里对特定的已知消息进行处理
 end
else
 begin
   TranslateMessage(Msg);
   DispatchMessage(Msg);
 end;
这样进行，实践证明是可行的。你的代码好象也是这样进行，而且更详细，我觉得肯定不错。    

来源：http://www.delphibbs.com/keylife/iblog_show.asp?xid=26346