迪恩网络APP
随时随地掌握行业动态
扫描二维码
关注迪恩网络微信公众号
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} 使用线程消息队列来处理消息 但是现在好像还没有这样(用一个事件来处理).只是开始进入了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} |
2023-10-27
2022-08-15
2022-08-17
2022-09-23
2022-08-13
请发表评论