TMsgThread, TCommThread -- 在delphi线程中实现消息循环
http://delphi.cjcsoft.net//viewthread.php?tid=635
在delphi线程中实现消息循环
Delphi的TThread类使用很方便,但是有时候我们需要在线程类中使用消息循环,delphi没有提供.
- {-----------------------------------------------------------------------------
- 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,,,,,,,hInstance,nil);
- SetWindowLong(FMSGWin, GWL_WNDPROC, Longint(MakeObjectInstance(MSGWinProc)));
- {$ELSE}
- PeekMessage(Msg,,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,,,,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,,,);
- 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 <> then
- begin
- aEvent := FEventList.Items[];
- if aEvent <> nil then
- begin
- SetEvent(aEvent^);
- CloseHandle(aEvent^);
- Dispose(aEvent);
- end;
- FEventList.Delete();
- 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,,,,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();
- end;
- {//////////////////////////////////////////////////////////////////////////////}
- procedure TMsgThread.QuitThread;
- begin
- {$IFDEF USE_WINDOW_MESSAGE}
- PostMessage(FMSGWin,WM_QUIT,,);
- {$ELSE}
- PostThreadMessage(ThreadID,WM_QUIT,,);
- {$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,,);
- 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, ) = WAIT_TIMEOUT do
- begin
- Application.ProcessMessages;
- if GetTickCount > (xStart + ) then
- begin
- TerminateThread(Handle, );
- 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 : 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 = ) : 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 := ;
- 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, , , , , , , hInstance, nil );
- SetWindowLong( SyncWindow, GWL_WNDPROC, Longint( MakeObjectInstance( SyncWindowProc ) ) );
- FWaitHandle := CreateEvent( nil, True, False, nil );
- // Create Thread
- m_hThread := CreateThread( nil, , @msgThdInitialThreadProc, Self, , threadid );
- if m_hThread = then
- raise EMsgThreadErr.Create( '不能创建线程。' );
- // Wait until thread Message Loop started
- WaitForSingleObject( FWaitHandle, INFINITE );
- end;
- { ------------------------------------------------------------------------------ }
- destructor TMsgThread.destroy;
- begin
- if m_hThread <> 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, , , , , , , hInstance, nil );
- SetWindowLong( FMSGWin, GWL_WNDPROC, Longint( MakeObjectInstance( MSGWinProc ) ) );
- {$ELSE}
- PeekMessage( Msg, , 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, , , , 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, , , );
- 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 <> then
- begin
- aEvent := FEventList.Items[ ];
- if aEvent <> nil then
- begin
- SetEvent( aEvent^ );
- CloseHandle( aEvent^ );
- Dispose( aEvent );
- WaitForSingleObject( fSendMsgComp, INFINITE );
- end;
- FEventList.Delete( );
- 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, , , , 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( );
- end;
- { ////////////////////////////////////////////////////////////////////////////// }
- function TMsgThread.ThreadExists : BOOL;
- begin
- if m_hThread = then
- Result := False
- else
- Result := True;
- end;
- { ------------------------------------------------------------------------------ }
- procedure TMsgThread.QuitThread;
- begin
- {$IFDEF USE_WINDOW_MESSAGE}
- PostMessage( FMSGWin, WM_QUIT, , );
- {$ELSE}
- PostThreadMessage( threadid, WM_QUIT, , );
- {$ENDIF}
- end;
- { ------------------------------------------------------------------------------ }
- procedure TMsgThread.SetDoLoop( const Value : Boolean );
- begin
- if Value = fDoLoop then
- Exit;
- fDoLoop := Value;
- if fDoLoop then
- PostMsg( WM_USER, , );
- end;
- { ------------------------------------------------------------------------------ }
- function TMsgThread.WaitTimeOut( timeout : DWORD ) : Longword;
- var
- xStart : Cardinal;
- H : THandle;
- begin
- H := m_hThread;
- xStart := GetTickCount;
- while WaitForSingleObject( H, ) = WAIT_TIMEOUT do
- begin
- Application.ProcessMessages;
- if GetTickCount > ( xStart + timeout ) then
- begin
- TerminateThread( H, );
- 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( , H, False, INFINITE, QS_SENDMESSAGE )
- = WAIT_OBJECT_ + do
- PeekMessage( Msg, , , , 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, , Longint( Self ) );
- end;
- { ------------------------------------------------------------------------------ }
- procedure TMsgThread.SyncWindowProc( var Message : TMessage );
- begin
- case message.Msg of
- NM_EXECPROC :
- with TMsgThread( message.lParam ) do
- begin
- message.Result := ;
- try
- FMethod;
- except
- raise EMsgThreadErr.Create( '执行同步线程方法错误。' );
- end;
- end;
- else
- message.Result := DefWindowProc( SyncWindow, message.Msg, message.wParam,
- message.lParam );
- end;
- end;
- end.
I took a look at OmniThreadLibrary and it looked like overkill for my purposes.
I wrote a simple library I call TCommThread.
It allows you to pass data back to the main thread without worrying about
any of the complexities of threads or Windows messages.
Here's the code if you'd like to try it.
CommThread Library:
- unit Threading.CommThread;
- interface
- uses
- Classes, SysUtils, ExtCtrls, SyncObjs, Generics.Collections, DateUtils;
- const
- CTID_USER = ;
- PRM_USER = ;
- CTID_STATUS = ;
- CTID_PROGRESS = ;
- type
- TThreadParams = class(TDictionary<String, Variant>);
- TThreadObjects = class(TDictionary<String, TObject>);
- TCommThreadParams = class(TObject)
- private
- FThreadParams: TThreadParams;
- FThreadObjects: TThreadObjects;
- public
- constructor Create;
- destructor Destroy; override;
- procedure Clear;
- function GetParam(const ParamName: String): Variant;
- function SetParam(const ParamName: String; ParamValue: Variant): TCommThreadParams;
- function GetObject(const ObjectName: String): TObject;
- function SetObject(const ObjectName: String; Obj: TObject): TCommThreadParams;
- end;
- TCommQueueItem = class(TObject)
- private
- FSender: TObject;
- FMessageId: Integer;
- FCommThreadParams: TCommThreadParams;
- public
- destructor Destroy; override;
- property Sender: TObject read FSender write FSender;
- property MessageId: Integer read FMessageId write FMessageId;
- property CommThreadParams: TCommThreadParams read FCommThreadParams write FCommThreadParams;
- end;
- TCommQueue = class(TQueue<TCommQueueItem>);
- ICommDispatchReceiver = interface
- ['{A4E2C9D1-E4E8-497D-A9BF-FAFE2D3A7C49}']
- procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
- procedure CommThreadTerminated(Sender: TObject);
- function Cancelled: Boolean;
- end;
- TCommThread = class(TThread)
- protected
- FCommThreadParams: TCommThreadParams;
- FCommDispatchReceiver: ICommDispatchReceiver;
- FName: String;
- FProgressFrequency: Integer;
- FNextSendTime: TDateTime;
- procedure SendStatusMessage(const StatusText: String; StatusType: Integer = ); virtual;
- procedure SendProgressMessage(ProgressID: Int64; Progress, ProgressMax: Integer; AlwaysSend: Boolean = TRUE); virtual;
- public
- constructor Create(CommDispatchReceiver: TObject); reintroduce; virtual;
- destructor Destroy; override;
- function SetParam(const ParamName: String; ParamValue: Variant): TCommThread;
- function GetParam(const ParamName: String): Variant;
- function SetObject(const ObjectName: String; Obj: TObject): TCommThread;
- function GetObject(const ObjectName: String): TObject;
- procedure SendCommMessage(MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;
- property Name: String read FName;
- end;
- TCommThreadClass = Class of TCommThread;
- TCommThreadQueue = class(TObjectList<TCommThread>);
- TCommThreadDispatchState = (
- ctsIdle,
- ctsActive,
- ctsTerminating
- );
- TOnReceiveThreadMessage = procedure(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams) of object;
- TOnStateChange = procedure(Sender: TObject; State: TCommThreadDispatchState) of object;
- TOnStatus = procedure(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer) of object;
- TOnProgress = procedure(Source, Sender: TObject; const ID: String; Progress, ProgressMax: Integer) of object;
- TBaseCommThreadDispatch = class(TComponent, ICommDispatchReceiver)
- private
- FProcessQueueTimer: TTimer;
- FCSReceiveMessage: TCriticalSection;
- FCSCommThreads: TCriticalSection;
- FCommQueue: TCommQueue;
- FActiveThreads: TList;
- FCommThreadClass: TCommThreadClass;
- FCommThreadDispatchState: TCommThreadDispatchState;
- function CreateThread(const ThreadName: String = ''): TCommThread;
- function GetActiveThreadCount: Integer;
- function GetStateText: String;
- protected
- FOnReceiveThreadMessage: TOnReceiveThreadMessage;
- FOnStateChange: TOnStateChange;
- FOnStatus: TOnStatus;
- FOnProgress: TOnProgress;
- FManualMessageQueue: Boolean;
- FProgressFrequency: Integer;
- procedure SetManualMessageQueue(const Value: Boolean);
- procedure SetProcessQueueTimerInterval(const Value: Integer);
- procedure SetCommThreadDispatchState(const Value: TCommThreadDispatchState);
- procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
- procedure OnProcessQueueTimer(Sender: TObject);
- function GetProcessQueueTimerInterval: Integer;
- procedure CommThreadTerminated(Sender: TObject); virtual;
- function Finished: Boolean; virtual;
- procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;
- procedure DoOnStateChange; virtual;
- procedure TerminateActiveThreads;
- property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
- property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
- property OnStatus: TOnStatus read FOnStatus write FOnStatus;
- property OnProgress: TOnProgress read FOnProgress write FOnProgress;
- property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
- property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
- property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
- property CommThreadDispatchState: TCommThreadDispatchState read FCommThreadDispatchState write SetCommThreadDispatchState;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- function NewThread(const ThreadName: String = ''): TCommThread; virtual;
- procedure ProcessMessageQueue; virtual;
- procedure Stop; virtual;
- function State: TCommThreadDispatchState;
- function Cancelled: Boolean;
- property ActiveThreadCount: Integer read GetActiveThreadCount;
- property StateText: String read GetStateText;
- property CommThreadClass: TCommThreadClass read FCommThreadClass write FCommThreadClass;
- end;
- TCommThreadDispatch = class(TBaseCommThreadDispatch)
- published
- property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
- property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
- property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
- property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
- property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
- end;
- TBaseStatusCommThreadDispatch = class(TBaseCommThreadDispatch)
- protected
- FOnStatus: TOnStatus;
- FOnProgress: TOnProgress;
- procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); override;
- procedure DoOnStatus(Sender: TObject;const ID: String; const StatusText: String; StatusType: Integer); virtual;
- procedure DoOnProgress(Sender: TObject; const ID: String; Progress, ProgressMax: Integer); virtual;
- property OnStatus: TOnStatus read FOnStatus write FOnStatus;
- property OnProgress: TOnProgress read FOnProgress write FOnProgress;
- end;
- TStatusCommThreadDispatch = class(TBaseStatusCommThreadDispatch)
- published
- property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
- property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
- property OnStatus: TOnStatus read FOnStatus write FOnStatus;
- property OnProgress: TOnProgress read FOnProgress write FOnProgress;
- property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
- property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
- property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
- end;
- implementation
- const
- PRM_STATUS_TEXT = 'Status';
- PRM_STATUS_TYPE = 'Type';
- PRM_PROGRESS_ID = 'ProgressID';
- PRM_PROGRESS = 'Progess';
- PRM_PROGRESS_MAX = 'ProgressMax';
- resourcestring
- StrCommReceiverMustSupportInterface = 'CommDispatchReceiver must support ICommDispatchReceiver interface';
- StrSenderMustBeATCommThread = 'Sender must be a TCommThread';
- StrUnableToFindTerminatedThread = 'Unable to find the terminated thread';
- StrIdle = 'Idle';
- StrTerminating = 'Terminating';
- StrActive = 'Active';
- { TCommThread }
- constructor TCommThread.Create(CommDispatchReceiver: TObject);
- begin
- Assert(Supports(CommDispatchReceiver, ICommDispatchReceiver, FCommDispatchReceiver), StrCommReceiverMustSupportInterface);
- inherited Create(TRUE);
- FCommThreadParams := TCommThreadParams.Create;
- end;
- destructor TCommThread.Destroy;
- begin
- FCommDispatchReceiver.CommThreadTerminated(Self);
- FreeAndNil(FCommThreadParams);
- inherited;
- end;
- function TCommThread.GetObject(const ObjectName: String): TObject;
- begin
- Result := FCommThreadParams.GetObject(ObjectName);
- end;
- function TCommThread.GetParam(const ParamName: String): Variant;
- begin
- Result := FCommThreadParams.GetParam(ParamName);
- end;
- procedure TCommThread.SendCommMessage(MessageId: Integer;
- CommThreadParams: TCommThreadParams);
- begin
- FCommDispatchReceiver.QueueMessage(Self, MessageId, CommThreadParams);
- end;
- procedure TCommThread.SendProgressMessage(ProgressID: Int64; Progress,
- ProgressMax: Integer; AlwaysSend: Boolean);
- begin
- if (AlwaysSend) or (now > FNextSendTime) then
- begin
- // Send a status message to the comm receiver
- SendCommMessage(CTID_PROGRESS, TCommThreadParams.Create
- .SetParam(PRM_PROGRESS_ID, ProgressID)
- .SetParam(PRM_PROGRESS, Progress)
- .SetParam(PRM_PROGRESS_MAX, ProgressMax));
- if not AlwaysSend then
- FNextSendTime := now + (FProgressFrequency * OneMillisecond);
- end;
- end;
- procedure TCommThread.SendStatusMessage(const StatusText: String;
- StatusType: Integer);
- begin
- // Send a status message to the comm receiver
- SendCommMessage(CTID_STATUS, TCommThreadParams.Create
- .SetParam(PRM_STATUS_TEXT, StatusText)
- .SetParam(PRM_STATUS_TYPE, StatusType));
- end;
- function TCommThread.SetObject(const ObjectName: String;
- Obj: TObject): TCommThread;
- begin
- Result := Self;
- FCommThreadParams.SetObject(ObjectName, Obj);
- end;
- function TCommThread.SetParam(const ParamName: String;
- ParamValue: Variant): TCommThread;
- begin
- Result := Self;
- FCommThreadParams.SetParam(ParamName, ParamValue);
- end;
- { TCommThreadDispatch }
- function TBaseCommThreadDispatch.Cancelled: Boolean;
- begin
- Result := State = ctsTerminating;
- end;
- procedure TBaseCommThreadDispatch.CommThreadTerminated(Sender: TObject);
- var
- idx: Integer;
- begin
- FCSCommThreads.Enter;
- try
- Assert(Sender is TCommThread, StrSenderMustBeATCommThread);
- // Find the thread in the active thread list
- idx := FActiveThreads.IndexOf(Sender);
- Assert(idx <> -, StrUnableToFindTerminatedThread);
- // if we find it, remove it (we should always find it)
- FActiveThreads.Delete(idx);
- finally
- FCSCommThreads.Leave;
- end;
- end;
- constructor TBaseCommThreadDispatch.Create(AOwner: TComponent);
- begin
- inherited;
- FCommThreadClass := TCommThread;
- FProcessQueueTimer := TTimer.Create(nil);
- FProcessQueueTimer.Enabled := FALSE;
- FProcessQueueTimer.Interval := ;
- FProcessQueueTimer.OnTimer := OnProcessQueueTimer;
- FProgressFrequency := ;
- FCommQueue := TCommQueue.Create;
- FActiveThreads := TList.Create;
- FCSReceiveMessage := TCriticalSection.Create;
- FCSCommThreads := TCriticalSection.Create;
- end;
- destructor TBaseCommThreadDispatch.Destroy;
- begin
- // Stop the queue timer
- FProcessQueueTimer.Enabled := FALSE;
- TerminateActiveThreads;
- // Pump the queue while there are active threads
- while CommThreadDispatchState <> ctsIdle do
- begin
- ProcessMessageQueue;
- sleep();
- end;
- // Free everything
- FreeAndNil(FProcessQueueTimer);
- FreeAndNil(FCommQueue);
- FreeAndNil(FCSReceiveMessage);
- FreeAndNil(FCSCommThreads);
- FreeAndNil(FActiveThreads);
- inherited;
- end;
- procedure TBaseCommThreadDispatch.DoOnReceiveThreadMessage(Sender: TObject;
- MessageId: Integer; CommThreadParams: TCommThreadParams);
- begin
- // Don't send the messages if we're being destroyed
- if not (csDestroying in ComponentState) then
- begin
- if Assigned(FOnReceiveThreadMessage) then
- FOnReceiveThreadMessage(Self, Sender, MessageId, CommThreadParams);
- end;
- end;
- procedure TBaseCommThreadDispatch.DoOnStateChange;
- begin
- if (Assigned(FOnStateChange)) and (not (csDestroying in ComponentState)) then
- FOnStateChange(Self, FCommThreadDispatchState);
- end;
- function TBaseCommThreadDispatch.GetActiveThreadCount: Integer;
- begin
- Result := FActiveThreads.Count;
- end;
- function TBaseCommThreadDispatch.GetProcessQueueTimerInterval: Integer;
- begin
- Result := FProcessQueueTimer.Interval;
- end;
- function TBaseCommThreadDispatch.GetStateText: String;
- begin
- case State of
- ctsIdle: Result := StrIdle;
- ctsTerminating: Result := StrTerminating;
- ctsActive: Result := StrActive;
- end;
- end;
- function TBaseCommThreadDispatch.NewThread(const ThreadName: String): TCommThread;
- begin
- if FCommThreadDispatchState = ctsTerminating then
- Result := nil
- else
- begin
- // Make sure we're active
- if CommThreadDispatchState = ctsIdle then
- CommThreadDispatchState := ctsActive;
- Result := CreateThread(ThreadName);
- FActiveThreads.Add(Result);
- if ThreadName = '' then
- Result.FName := IntToStr(Integer(Result))
- else
- Result.FName := ThreadName;
- Result.FProgressFrequency := FProgressFrequency;
- end;
- end;
- function TBaseCommThreadDispatch.CreateThread(
- const ThreadName: String): TCommThread;
- begin
- Result := FCommThreadClass.Create(Self);
- Result.FreeOnTerminate := TRUE;
- end;
- procedure TBaseCommThreadDispatch.OnProcessQueueTimer(Sender: TObject);
- begin
- ProcessMessageQueue;
- end;
- procedure TBaseCommThreadDispatch.ProcessMessageQueue;
- var
- CommQueueItem: TCommQueueItem;
- begin
- if FCommThreadDispatchState in [ctsActive, ctsTerminating] then
- begin
- if FCommQueue.Count > then
- begin
- FCSReceiveMessage.Enter;
- try
- CommQueueItem := FCommQueue.Dequeue;
- while Assigned(CommQueueItem) do
- begin
- try
- DoOnReceiveThreadMessage(CommQueueItem.Sender, CommQueueItem.MessageId, CommQueueItem.CommThreadParams);
- finally
- FreeAndNil(CommQueueItem);
- end;
- if FCommQueue.Count > then
- CommQueueItem := FCommQueue.Dequeue;
- end;
- finally
- FCSReceiveMessage.Leave
- end;
- end;
- if Finished then
- begin
- FCommThreadDispatchState := ctsIdle;
- DoOnStateChange;
- end;
- end;
- end;
- function TBaseCommThreadDispatch.Finished: Boolean;
- begin
- Result := FActiveThreads.Count = ;
- end;
- procedure TBaseCommThreadDispatch.QueueMessage(Sender: TObject; MessageId: Integer;
- CommThreadParams: TCommThreadParams);
- var
- CommQueueItem: TCommQueueItem;
- begin
- FCSReceiveMessage.Enter;
- try
- CommQueueItem := TCommQueueItem.Create;
- CommQueueItem.Sender := Sender;
- CommQueueItem.MessageId := MessageId;
- CommQueueItem.CommThreadParams := CommThreadParams;
- FCommQueue.Enqueue(CommQueueItem);
- finally
- FCSReceiveMessage.Leave
- end;
- end;
- procedure TBaseCommThreadDispatch.SetCommThreadDispatchState(
- const Value: TCommThreadDispatchState);
- begin
- if FCommThreadDispatchState <> ctsTerminating then
- begin
- if Value = ctsActive then
- begin
- if not FManualMessageQueue then
- FProcessQueueTimer.Enabled := TRUE;
- end
- else
- TerminateActiveThreads;
- end;
- FCommThreadDispatchState := Value;
- DoOnStateChange;
- end;
- procedure TBaseCommThreadDispatch.SetManualMessageQueue(const Value: Boolean);
- begin
- FManualMessageQueue := Value;
- end;
- procedure TBaseCommThreadDispatch.SetProcessQueueTimerInterval(const Value: Integer);
- begin
- FProcessQueueTimer.Interval := Value;
- end;
- function TBaseCommThreadDispatch.State: TCommThreadDispatchState;
- begin
- Result := FCommThreadDispatchState;
- end;
- procedure TBaseCommThreadDispatch.Stop;
- begin
- if CommThreadDispatchState = ctsActive then
- TerminateActiveThreads;
- end;
- procedure TBaseCommThreadDispatch.TerminateActiveThreads;
- var
- i: Integer;
- begin
- if FCommThreadDispatchState = ctsActive then
- begin
- // Lock threads
- FCSCommThreads.Acquire;
- try
- FCommThreadDispatchState := ctsTerminating;
- DoOnStateChange;
- // Terminate each thread in turn
- for i := to pred(FActiveThreads.Count) do
- TCommThread(FActiveThreads[i]).Terminate;
- finally
- FCSCommThreads.Release;
- end;
- end;
- end;
- { TCommThreadParams }
- procedure TCommThreadParams.Clear;
- begin
- FThreadParams.Clear;
- FThreadObjects.Clear;
- end;
- constructor TCommThreadParams.Create;
- begin
- FThreadParams := TThreadParams.Create;
- FThreadObjects := TThreadObjects.Create;
- end;
- destructor TCommThreadParams.Destroy;
- begin
- FreeAndNil(FThreadParams);
- FreeAndNil(FThreadObjects);
- inherited;
- end;
- function TCommThreadParams.GetObject(const ObjectName: String): TObject;
- begin
- Result := FThreadObjects.Items[ObjectName];
- end;
- function TCommThreadParams.GetParam(const ParamName: String): Variant;
- begin
- Result := FThreadParams.Items[ParamName];
- end;
- function TCommThreadParams.SetObject(const ObjectName: String;
- Obj: TObject): TCommThreadParams;
- begin
- FThreadObjects.AddOrSetValue(ObjectName, Obj);
- Result := Self;
- end;
- function TCommThreadParams.SetParam(const ParamName: String;
- ParamValue: Variant): TCommThreadParams;
- begin
- FThreadParams.AddOrSetValue(ParamName, ParamValue);
- Result := Self;
- end;
- { TCommQueueItem }
- destructor TCommQueueItem.Destroy;
- begin
- if Assigned(FCommThreadParams) then
- FreeAndNil(FCommThreadParams);
- inherited;
- end;
- { TBaseStatusCommThreadDispatch }
- procedure TBaseStatusCommThreadDispatch.DoOnReceiveThreadMessage(
- Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
- begin
- inherited;
- case MessageId of
- // Status Message
- CTID_STATUS: DoOnStatus(Sender,
- Name,
- CommThreadParams.GetParam(PRM_STATUS_TEXT),
- CommThreadParams.GetParam(PRM_STATUS_TYPE));
- // Progress Message
- CTID_PROGRESS: DoOnProgress(Sender,
- CommThreadParams.GetParam(PRM_PROGRESS_ID),
- CommThreadParams.GetParam(PRM_PROGRESS),
- CommThreadParams.GetParam(PRM_PROGRESS_MAX));
- end;
- end;
- procedure TBaseStatusCommThreadDispatch.DoOnStatus(Sender: TObject; const ID,
- StatusText: String; StatusType: Integer);
- begin
- if (not (csDestroying in ComponentState)) and (Assigned(FOnStatus)) then
- FOnStatus(Self, Sender, ID, StatusText, StatusType);
- end;
- procedure TBaseStatusCommThreadDispatch.DoOnProgress(Sender: TObject;
- const ID: String; Progress, ProgressMax: Integer);
- begin
- if not (csDestroying in ComponentState) and (Assigned(FOnProgress)) then
- FOnProgress(Self, Sender, ID, Progress, ProgressMax);
- end;
- end.
To use the library, simply descend your thread from the TCommThread thread and override the Execute procedure:
MyCommThreadObject = class(TCommThread)
public
procedure Execute; override;
end;
Next, create a descendant of the TStatusCommThreadDispatch component and set it's events.
MyCommThreadComponent := TStatusCommThreadDispatch.Create(Self); // Add the event handlers
MyCommThreadComponent.OnStateChange := OnStateChange;
MyCommThreadComponent.OnReceiveThreadMessage := OnReceiveThreadMessage;
MyCommThreadComponent.OnStatus := OnStatus;
MyCommThreadComponent.OnProgress := OnProgress; // Set the thread class
MyCommThreadComponent.CommThreadClass := TMyCommThread;
Make sure you set the CommThreadClass to your TCommThread descendant.
Now all you need to do is create the threads via MyCommThreadComponent:
FCommThreadComponent.NewThread
.SetParam('MyThreadInputParameter', '')
.SetObject('MyThreadInputObject', MyObject)
.Start;
Add as many parameters and objects as you like. In your threads Execute method you can retrieve the parameters and objects.
MyThreadParameter := GetParam('MyThreadInputParameter'); //
MyThreadObject := GetObject('MyThreadInputObject'); // MyObject
Parameters will be automatically freed. You need to manage objects yourself.
To send a message back to the main thread from the threads execute method:
FCommDispatchReceiver.QueueMessage(Self, CTID_MY_MESSAGE_ID, TCommThreadParams.Create
.SetObject('MyThreadObject', MyThreadObject)
.SetParam('MyThreadOutputParameter', MyThreadParameter));
Again, parameters will be destroyed automatically, objects you have to manage yourself.
To receive messages in the main thread either attach the OnReceiveThreadMessage event
or override the DoOnReceiveThreadMessage procedure:
procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); override;
Use the overridden procedure to process the messages sent back to your main thread:
procedure THostDiscovery.DoOnReceiveThreadMessage(Sender: TObject;
MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
inherited; case MessageId of CTID_MY_MESSAGE_ID:
begin
// Process the CTID_MY_MESSAGE_ID message
DoSomethingWithTheMessage(CommThreadParams.GetParam('MyThreadOutputParameter'),
CommThreadParams.GeObject('MyThreadObject'));
end;
end;
end;
The messages are pumped in the ProcessMessageQueue procedure.
This procedure is called via a TTimer.
If you use the component in a console app you will need to call ProcessMessageQueue manually.
The timer will start when the first thread is created.
It will stop when the last thread has finished.
If you need to control when the timer stops you can override the Finished procedure.
You can also perform actions depending on the state of the threads by overriding the DoOnStateChange procedure.
Take a look at the TCommThread descendant TStatusCommThreadDispatch.
It implements the sending of simple Status and Progress messages back to the main thread.
I hope this helps and that I've explained it OK.
This is related to my previous answer, but I was limited to 30000 characters.
Here's the code for a test app that uses TCommThread:
Test App (.pas)
unit frmMainU; interface uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, ExtCtrls, StdCtrls, Threading.CommThread; type
TMyCommThread = class(TCommThread)
public
procedure Execute; override;
end; TfrmMain = class(TForm)
Panel1: TPanel;
lvLog: TListView;
btnStop: TButton;
btnNewThread: TButton;
StatusBar1: TStatusBar;
btn30NewThreads: TButton;
tmrUpdateStatusBar: TTimer;
procedure FormCreate(Sender: TObject);
procedure btnStopClick(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure tmrUpdateStatusBarTimer(Sender: TObject);
private
FCommThreadComponent: TStatusCommThreadDispatch; procedure OnReceiveThreadMessage(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
procedure OnStateChange(Sender: TObject; State: TCommThreadDispatchState);
procedure UpdateStatusBar;
procedure OnStatus(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer);
procedure OnProgress(Source, Sender: TObject; const ID: String; Progress, ProgressMax: Integer);
public end; var
frmMain: TfrmMain; implementation resourcestring
StrStatusIDDProgre = 'StatusID: %s, Progress: %d, ProgressMax: %d';
StrActiveThreadsD = 'Active Threads: %d, State: %s';
StrIdle = 'Idle';
StrActive = 'Active';
StrTerminating = 'Terminating'; {$R *.dfm} { TMyCommThread } procedure TMyCommThread.Execute;
var
i: Integer;
begin
SendCommMessage(, TCommThreadParams.Create.SetParam('status', 'started')); for i := to do
begin
sleep(); SendStatusMessage(format('Thread: %s, i = %d', [Name, i]), ); if Terminated then
Break; sleep(); SendProgressMessage(Integer(Self), i, , FALSE);
end; if Terminated then
SendCommMessage(, TCommThreadParams.Create.SetParam('status', 'terminated'))
else
SendCommMessage(, TCommThreadParams.Create.SetParam('status', 'finished'));
end; { TfrmMain } procedure TfrmMain.btnStopClick(Sender: TObject);
begin
FCommThreadComponent.Stop;
end; procedure TfrmMain.Button3Click(Sender: TObject);
var
i: Integer;
begin
for i := to do
FCommThreadComponent.NewThread
.SetParam('input_param1', 'test_value')
.Start;
end; procedure TfrmMain.Button4Click(Sender: TObject);
begin
FCommThreadComponent.NewThread
.SetParam('input_param1', 'test_value')
.Start;
end; procedure TfrmMain.FormCreate(Sender: TObject);
begin
FCommThreadComponent := TStatusCommThreadDispatch.Create(Self); // Add the event handlers
FCommThreadComponent.OnStateChange := OnStateChange;
FCommThreadComponent.OnReceiveThreadMessage := OnReceiveThreadMessage;
FCommThreadComponent.OnStatus := OnStatus;
FCommThreadComponent.OnProgress := OnProgress; // Set the thread class
FCommThreadComponent.CommThreadClass := TMyCommThread;
end; procedure TfrmMain.OnProgress(Source, Sender: TObject; const ID: String; Progress, ProgressMax: Integer);
begin
With lvLog.Items.Add do
begin
Caption := '-'; SubItems.Add(format(StrStatusIDDProgre, [Id, Progress, ProgressMax]));
end;
end; procedure TfrmMain.OnReceiveThreadMessage(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
if MessageID = then
With lvLog.Items.Add do
begin
Caption := IntToStr(MessageId); SubItems.Add(CommThreadParams.GetParam('status'));
end;
end; procedure TfrmMain.UpdateStatusBar;
begin
StatusBar1.SimpleText := format(StrActiveThreadsD, [FCommThreadComponent.ActiveThreadCount, FCommThreadComponent.StateText]);
end; procedure TfrmMain.OnStateChange(Sender: TObject; State: TCommThreadDispatchState);
begin
With lvLog.Items.Add do
begin
case State of
ctsIdle: Caption := StrIdle;
ctsActive: Caption := StrActive;
ctsTerminating: Caption := StrTerminating;
end;
end;
end; procedure TfrmMain.OnStatus(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer);
begin
With lvLog.Items.Add do
begin
Caption := IntToStr(StatusType); SubItems.Add(StatusText);
end;
end; procedure TfrmMain.tmrUpdateStatusBarTimer(Sender: TObject);
begin
UpdateStatusBar;
end; end.
Test app (.dfm)
object frmMain: TfrmMain
Left =
Top =
Caption = 'CommThread Test'
ClientHeight =
ClientWidth =
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch =
TextHeight =
object Panel1: TPanel
AlignWithMargins = True
Left =
Top =
Width =
Height =
Margins.Right =
Align = alLeft
BevelOuter = bvNone
TabOrder =
object btnStop: TButton
AlignWithMargins = True
Left =
Top =
Width =
Height =
Margins.Left =
Margins.Top =
Margins.Right =
Margins.Bottom =
Align = alTop
Caption = 'Stop'
TabOrder =
OnClick = btnStopClick
end
object btnNewThread: TButton
Left =
Top =
Width =
Height =
Align = alTop
Caption = 'New Thread'
TabOrder =
OnClick = Button4Click
end
object btn30NewThreads: TButton
Left =
Top =
Width =
Height =
Align = alTop
Caption = '30 New Threads'
TabOrder =
OnClick = Button3Click
end
end
object lvLog: TListView
AlignWithMargins = True
Left =
Top =
Width =
Height =
Align = alClient
Columns = <
item
Caption = 'Message ID'
Width =
end
item
AutoSize = True
Caption = 'Info'
end>
ReadOnly = True
RowSelect = True
TabOrder =
ViewStyle = vsReport
end
object StatusBar1: TStatusBar
Left =
Top =
Width =
Height =
Panels = <>
SimplePanel = True
end
object tmrUpdateStatusBar: TTimer
Interval =
OnTimer = tmrUpdateStatusBarTimer
Left =
Top =
end
end
TMsgThread, TCommThread -- 在delphi线程中实现消息循环的更多相关文章
- TMsgThread, TCommThread -- 在delphi线程中实现消息循环(105篇博客,好多研究消息的文章)
在delphi线程中实现消息循环 在delphi线程中实现消息循环 Delphi的TThread类使用很方便,但是有时候我们需要在线程类中使用消息循环,delphi没有提供. 花了两天的事件研究了 ...
- TCommThread -- 在delphi线程中实现消息循环
http://www.techques.com/question/1-4073197/How-do-I-send-and-handle-message-between-TService-parent- ...
- Looper.loop() android线程中的消息循环
Looper用于封装了android线程中的消息循环,默认情况下一个线程是不存在消息循环(message loop)的,需要调用Looper.prepare()来给线程创建一个消息循环,调用Loope ...
- 安卓中的消息循环机制Handler及Looper详解
我们知道安卓中的UI线程不是线程安全的,我们不能在UI线程中进行耗时操作,通常我们的做法是开启一个子线程在子线程中处理耗时操作,但是安卓规定不允许在子线程中进行UI的更新操作,通常我们会通过Handl ...
- delphi XE7 中的消息
在delphi XE7的程序开发中,消息机制保证进程间的通信. 在程序中,消息来自: 1)系统: 通知你的程序用户输入,涂画以及其他的系统范围的事件: 2)你的程序:不同的程序部分之间的通信信息. ...
- 【转载】Delphi7从子线程中发送消息到主线程触发事件执行
在对数据库的操作时,有时要用一个子线程来进行后台的数据操作.比如说数据备份,转档什么的.在主窗口还能同是进行其它操作.而有时后台每处理一个数据文件,要向主窗口发送消息,让主窗口实时显示处理进度在窗口上 ...
- Chrome中的消息循环
主要是自己做个学习笔记吧,我经验也不是很丰富,以前学习多线程的时候就感觉写多线程程序很麻烦.主要是线程之间要通信,要切线程,要同步,各种麻烦.我本身的工作经历决定了也没有太多的工作经验,所以chrom ...
- Windows 消息循环(2) - WPF中的消息循环
接上文: Windows 消息循环(1) - 概览 win32/MFC/WinForm/WPF 都依靠消息循环驱动,让程序跑起来. 本文介绍 WPF 中是如何使用消息循环来驱动程序的. 4 消息循环在 ...
- 事件循环和线程没有必然关系(就像Windows子线程默认没有消息循环一样),模态对话框和事件循环也没有必然关系(QWidget直接就可以)
周末天冷,索性把电脑抱到床上上网,这几天看了 dbzhang800 博客关于 Qt 事件循环的几篇 Blog,发现自己对 Qt 的事件循环有不少误解.从来只看到现象,这次借 dbzhang800 的博 ...
随机推荐
- 可进行JavaScript代码测试与调试的12个网站
概述:JavaScript是网站前端开发最为重要的一门编程语言,本文收集了能够在线测试与调试JavaScript代码的12个网站 1.JS Bin JS bin是一个为JavaScript和CSS爱好 ...
- 多态.xml
pre{ line-height:1; color:#1e1e1e; background-color:#f0f0f0; font-size:16px;}.sysFunc{color:#627cf6; ...
- 数往知来C#之接口 值类型与引用类型 静态非静态 异常处理 GC垃圾回收 值类型引用类型内存分配<四>
C# 基础接口篇 一.多态复习 使用个new来实现,使用virtual与override -->new隐藏父类方法 根据当前类型,电泳对应的方法(成员) -->override ...
- fork()函数详解
linux中fork()函数详解(原创!!实例讲解) (转载) 一.fork入门知识 一个进程,包括代码.数据和分配给进程的资源.fork()函数通过系统调用创建一个与原来进程几乎完全相同的进程 ...
- 新手须知设计的法则 Mark
经常看到一些讲如何学习设计的文章,坦白讲感觉有些千篇一律.且不痛不痒,都说要看点书.学点画.练软件.多观察……唉,练软件这事还要说么,难道你还需要告诉一个人学开发是需要学习编程语言的? 学习是基于过往 ...
- Page Scroll Menu (页面中锚点菜单)
Technorati 标签: Page Scroll Menu,页面锚点菜单,Menu,Too Long,页面太长 当页面太长时,会导致浏览不便,这时就需要一个页面锚点菜单(Page Scroll ...
- iframe和frame的区别
在同时有frame和Iframe的一个窗口里frame最大可以做个frameset的儿子,Iframe最大也只能做到frameset的孙子.frame的布局限于几种,Iframe想放哪里放哪里.fra ...
- CircleLayout
CircleLayout https://developer.apple.com/library/ios/samplecode/CircleLayout/Introduction/Intro.html ...
- php 开发最好的ide: PhpStorm
PhpStorm 跨平台. 对PHP支持refactor功能. 自动生成phpdoc的注释,非常方便进行大型编程. 内置支持Zencode. 生成类的继承关系图,如果有一个类,多次继承之后,可以通过这 ...
- 未找到与约束contractname Microsoft.VisualStudio.Utilities.IContentTypeRegistryService
在項目中遇到的問題,網上找到的答案,做個記錄, 项目能打开,但是当要在项目中查看文件时弹出 未找到与约束 Microsoft.VisualStudio.Utilities.IContentTypeRe ...