在delphi线程中实现消息循环
2007-04-27 09:45
281 查看
在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;
e
fa87
nd;
{$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.
[align=right]2003-6-22 10:56:00 [/align]
2003-6-22 11:02:24
我参考了一下msdn,还有windows核心编程.
写了一个类来封装这个功能,不知道对不对.
里面使用了两个方法,一个使用一个隐含窗体来处理消息
还有一个是直接使用thread的消息队列来处理,但是这个时候sendmessage无法工作,所以我自己设想了一个方法,虽然不完全达到了要求但是我简单测试了一下,好像还能工作.
切换两种工作方式要修改编译条件
{$DEFINE USE_WINDOW_MESSAGE} 使用隐含窗体来处理消息
{-$DEFINE USE_WINDOW_MESSAGE} 使用线程消息队列来处理消息
.
[align=right] [/align]
2003-6-22 11:02:54
还有我想要等待线程开始进行消息循环的时候create函数才返回.但是现在好像还没有这样(用一个事件来处理).只是开始进入了threadexecute函数,线程的create就返回了.可能会出问题.
[align=right] [/align]
2003-6-23 8:55:22
通过设置 DoLoop属性可以设定线程是否循环(不阻塞等待消息),这样派生类线程在循环做一些其他事情的同时还可以接受消息. 例如:派生类里面循环发送缓冲区的数据,还可以响应其他线程发送过来的消息(如停止,启动,退出,等等)
[align=right] [/align]
2003-8-4 10:21:18
重新修改了一下，现在用起来基本没有问题了。
{-----------------------------------------------------------------------------
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.
[align=right] [/align]
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;
e
fa87
nd;
{$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.
[align=right]2003-6-22 10:56:00 [/align]
| 查看评语»»» |
我参考了一下msdn,还有windows核心编程.
写了一个类来封装这个功能,不知道对不对.
里面使用了两个方法,一个使用一个隐含窗体来处理消息
还有一个是直接使用thread的消息队列来处理,但是这个时候sendmessage无法工作,所以我自己设想了一个方法,虽然不完全达到了要求但是我简单测试了一下,好像还能工作.
切换两种工作方式要修改编译条件
{$DEFINE USE_WINDOW_MESSAGE} 使用隐含窗体来处理消息
{-$DEFINE USE_WINDOW_MESSAGE} 使用线程消息队列来处理消息
.
[align=right] [/align]
2003-6-22 11:02:54
还有我想要等待线程开始进行消息循环的时候create函数才返回.但是现在好像还没有这样(用一个事件来处理).只是开始进入了threadexecute函数,线程的create就返回了.可能会出问题.
[align=right] [/align]
2003-6-23 8:55:22
通过设置 DoLoop属性可以设定线程是否循环(不阻塞等待消息),这样派生类线程在循环做一些其他事情的同时还可以接受消息. 例如:派生类里面循环发送缓冲区的数据,还可以响应其他线程发送过来的消息(如停止,启动,退出,等等)
[align=right] [/align]
2003-8-4 10:21:18
重新修改了一下，现在用起来基本没有问题了。
{-----------------------------------------------------------------------------
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.
[align=right] [/align]
内容来自用户分享和网络整理，不保证内容的准确性，如有侵权内容，可联系管理员处理 
相关文章推荐
- TMsgThread, TCommThread -- 在delphi线程中实现消息循环
- 独立线程实现消息循环的Delphi定时器类
- 在delphi线程中实现消息循环
- 在delphi线程中实现消息循环
- TMsgThread, TCommThread -- 在delphi线程中实现消息循环（105篇博客，好多研究消息的文章）
- TCommThread -- 在delphi线程中实现消息循环
- Delphi中使用Win32 API创建内建消息循环的线程函数
- MFC 定时触发器实现循环给指定线程进行发送消息
- MFC 子线程消息循环的实现
- MPI：非阻塞实现节点间的循环消息传递
- window程序一个线程中可以有几个消息队列？和几个消息循环
- java线程实现简单 消息队列 1对1模式
- Android应用程序线程消息循环模型分析
- Python中线程的MQ消息队列实现以及消息队列的优点解析
- java实现【有三个线程ID分别是A、B、C,请有多线编程实现,在屏幕上循环打印10次ABC.】
- Android 实现通知消息水平播放、无限循环效果
- android 线程中创建消息循环Looper.prepare() Looper.loop()
- Semaphore实现的三个线程协作循环打印10次ABC的方法
- Delphi 200X、XE中如何用并行实现循环的计算
- 工作线程与消息循环