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

这样进行，实践证明是可行的。你的代码好象也是这样进行，而且更详细，我觉得肯定不错。