在delphi线程中实现消息循环
在delphi线程中实现消息循环
Delphi的TThread类使用很方便,但是有时候我们需要在线程类中使用消息循环,delphi没有提供.
花了两天的事件研究了一下win32的消息系统,写了一个线程内消息循环的测试.
但是没有具体应用过,贴出来给有这方面需求的DFW参考一下.希望大家和我讨论.
{-----------------------------------------------------------------------------
Unit Name: uMsgThread
Author: xwing
eMail : xwing@263.net ; MSN : xwing1979@hotmail.com
Purpose: Thread with message Loop
History:
2003-6-19, add function to Send Thread Message. ver 1.0
use Event List and waitforsingleObject
your can use WindowMessage or ThreadMessage
2003-6-18, Change to create a window to Recving message
2003-6-17, Begin.
-----------------------------------------------------------------------------}
unit uMsgThread;
interface
{$WARN SYMBOL_DEPRECATED OFF}
{$DEFINE USE_WINDOW_MESSAGE}
uses
Classes, windows, messages, forms, sysutils;
type
TMsgThread = class(TThread)
private
{$IFDEF USE_WINDOW_MESSAGE}
FWinName : string;
FMSGWin : HWND;
{$ELSE}
FEventList : TList;
FCtlSect : TRTLCriticalSection;
{$ENDIF}
FException : Exception;
fDoLoop : Boolean;
FWaitHandle : THandle;
{$IFDEF USE_WINDOW_MESSAGE}
procedure MSGWinProc(var Message: TMessage);
{$ELSE}
procedure ClearSendMsgEvent;
{$ENDIF}
procedure SetDoLoop(const Value: Boolean);
procedure WaitTerminate;
protected
Msg :tagMSG;
procedure Execute; override;
procedure HandleException;
procedure DoHandleException;virtual;
//Inherited the Method to process your own Message
procedure DoProcessMsg(var Msg:TMessage);virtual;
//if DoLoop = true then loop this procedure
//Your can use the method to do some work needed loop.
procedure DoMsgLoop;virtual;
//Initialize Thread before begin message loop
procedure DoInit;virtual;
procedure DoUnInit;virtual;
procedure PostMsg(Msg:Cardinal;wParam:Integer;lParam:Integer);
//When Use SendMsg method Must not use Synchronize Method in ThreadLoop !!!
//otherwise will caurse DeadLock
procedure SendMsg(Msg:Cardinal;wParam:Integer;lParam:Integer);
public
constructor Create(Loop:Boolean=False;ThreadName: string='');
destructor destroy;override;
procedure AfterConstruction;override;
//postMessage to Quit,and Free(if FreeOnTerminater = true)
//can call this in thread loop, don't use terminate property.
procedure QuitThread;
//PostMessage to Quit and Wait, only call in MAIN THREAD
procedure QuitThreadWait;
//just like Application.processmessage.
procedure ProcessMessage;
//enable thread loop, no waitfor message
property DoLoop: Boolean read fDoLoop Write SetDoLoop;
end;
implementation
{ TMsgThread }
{//////////////////////////////////////////////////////////////////////////////}
constructor TMsgThread.Create(Loop:Boolean;ThreadName:string);
begin
{$IFDEF USE_WINDOW_MESSAGE}
if ThreadName <> '' then
FWinName := ThreadName
else
FWinName := 'Thread Window';
{$ELSE}
FEventList := TList.Create;
InitializeCriticalSection(fCtlSect);
{$ENDIF}
FWaitHandle := CreateEvent(nil, True, False, nil);
FDoLoop := Loop; //default disable thread loop
inherited Create(False); //Create thread
FreeOnTerminate := True; //Thread quit and free object
//Call resume Method in Constructor Method
Resume;
//Wait until thread Message Loop started
WaitForSingleObject(FWaitHandle,INFINITE);
end;
{------------------------------------------------------------------------------}
procedure TMsgThread.AfterConstruction;
begin
end;
{------------------------------------------------------------------------------}
destructor TMsgThread.destroy;
begin
{$IFDEF USE_WINDOW_MESSAGE}
{$ELSE}
FEventList.Free;
DeleteCriticalSection(FCtlSect);
{$ENDIF}
inherited;
end;
{//////////////////////////////////////////////////////////////////////////////}
procedure TMsgThread.Execute;
var
mRet:Boolean;
aRet:Boolean;
{$IFNDEF USE_WINDOW_MESSAGE}
uMsg:TMessage;
{$ENDIF}
begin
{$IFDEF USE_WINDOW_MESSAGE}
FMSGWin := CreateWindow('STATIC',PChar(FWinName),WS_POPUP,0,0,0,0,0,0,hInstance,nil);
SetWindowLong(FMSGWin, GWL_WNDPROC, Longint(MakeObjectInstance(MSGWinProc)));
{$ELSE}
PeekMessage(Msg,0,WM_USER,WM_USER,PM_NOREMOVE); //Force system alloc a msgQueue
{$ENDIF}
//notify Conctructor can returen.
SetEvent(FWaitHandle);
CloseHandle(FWaitHandle);
mRet := True;
try
DoInit;
while mRet do //Message Loop
begin
if fDoLoop then
begin
aRet := PeekMessage(Msg,0,0,0,PM_REMOVE);
if aRet and (Msg.message <> WM_QUIT) then
begin
{$IFDEF USE_WINDOW_MESSAGE}
TranslateMessage(Msg);
DispatchMessage(Msg);
{$ELSE}
uMsg.Msg := Msg.message;
uMsg.wParam := Msg.wParam;
uMsg.lParam := Msg.lParam;
DoProcessMsg(uMsg);
{$ENDIF}
if Msg.message = WM_QUIT then
mRet := False;
end;
{$IFNDEF USE_WINDOW_MESSAGE}
ClearSendMsgEvent; //Clear SendMessage Event
{$ENDIF}
DoMsgLoop;
end
else begin
mRet := GetMessage(Msg,0,0,0);
if mRet then
begin
{$IFDEF USE_WINDOW_MESSAGE}
TranslateMessage(Msg);
DispatchMessage(Msg);
{$ELSE}
uMsg.Msg := Msg.message;
uMsg.wParam := Msg.wParam;
uMsg.lParam := Msg.lParam;
DoProcessMsg(uMsg);
ClearSendMsgEvent; //Clear SendMessage Event
{$ENDIF}
end;
end;
end;
DoUnInit;
{$IFDEF USE_WINDOW_MESSAGE}
DestroyWindow(FMSGWin);
FreeObjectInstance(Pointer(GetWindowLong(FMSGWin, GWL_WNDPROC)));
{$ENDIF}
except
HandleException;
end;
end;
{------------------------------------------------------------------------------}
{$IFNDEF USE_WINDOW_MESSAGE}
procedure TMsgThread.ClearSendMsgEvent;
var
aEvent:PHandle;
begin
EnterCriticalSection(FCtlSect);
try
if FEventList.Count <> 0 then
begin
aEvent := FEventList.Items[0];
if aEvent <> nil then
begin
SetEvent(aEvent^);
CloseHandle(aEvent^);
Dispose(aEvent);
end;
FEventList.Delete(0);
end;
finally
LeaveCriticalSection(FCtlSect);
end;
end;
{$ENDIF}
{------------------------------------------------------------------------------}
procedure TMsgThread.HandleException;
begin
FException := Exception(ExceptObject); //Get Current Exception object
try
if not (FException is EAbort) then
inherited Synchronize(DoHandleException);
finally
FException := nil;
end;
end;
{------------------------------------------------------------------------------}
procedure TMsgThread.DoHandleException;
begin
if FException is Exception then
Application.ShowException(FException)
else
SysUtils.ShowException(FException, nil);
end;
{//////////////////////////////////////////////////////////////////////////////}
{$IFDEF USE_WINDOW_MESSAGE}
procedure TMsgThread.MSGWinProc(var Message: TMessage);
begin
DoProcessMsg(Message);
with Message do
Result:=DefWindowProc(FMSGWin,Msg,wParam,lParam);
end;
{$ENDIF}
{------------------------------------------------------------------------------}
procedure TMsgThread.DoProcessMsg(var Msg:TMessage);
begin
end;
{------------------------------------------------------------------------------}
procedure TMsgThread.ProcessMessage;
{$IFNDEF USE_WINDOW_MESSAGE}
var
uMsg:TMessage;
{$ENDIF}
begin
while PeekMessage(Msg,0,0,0,PM_REMOVE) do
if Msg.message <> WM_QUIT then
begin
{$IFDEF USE_WINDOW_MESSAGE}
TranslateMessage(Msg);
DispatchMessage(msg);
{$ELSE}
uMsg.Msg := Msg.message;
uMsg.wParam := Msg.wParam;
uMsg.lParam := Msg.lParam;
DoProcessMsg(uMsg);
{$ENDIF}
end;
end;
{//////////////////////////////////////////////////////////////////////////////}
procedure TMsgThread.DoInit;
begin
end;
procedure TMsgThread.DoUnInit;
begin
end;
procedure TMsgThread.DoMsgLoop;
begin
Sleep(1);
end;
{//////////////////////////////////////////////////////////////////////////////}
procedure TMsgThread.QuitThread;
begin
{$IFDEF USE_WINDOW_MESSAGE}
PostMessage(FMSGWin,WM_QUIT,0,0);
{$ELSE}
PostThreadMessage(ThreadID,WM_QUIT,0,0);
{$ENDIF}
end;
{------------------------------------------------------------------------------}
procedure TMsgThread.QuitThreadWait;
begin
QuitThread;
WaitTerminate;
end;
{------------------------------------------------------------------------------}
procedure TMsgThread.SetDoLoop(const Value: Boolean);
begin
if Value = fDoLoop then Exit;
fDoLoop := Value;
if fDoLoop then
PostMsg(WM_USER,0,0);
end;
{------------------------------------------------------------------------------}
//Can only call this method in MAIN Thread!!
procedure TMsgThread.WaitTerminate;
var
xStart:Cardinal;
begin
xStart:=GetTickCount;
try
//EnableWindow(Application.Handle,False);
while WaitForSingleObject(Handle, 10) = WAIT_TIMEOUT do
begin
Application.ProcessMessages;
if GetTickCount > (xStart + 4000) then
begin
TerminateThread(Handle, 0);
Beep;
Break;
end;
end;
finally
//EnableWindow(Application.Handle,True);
end;
end;
{------------------------------------------------------------------------------}
procedure TMsgThread.PostMsg(Msg: Cardinal; wParam, lParam: Integer);
begin
{$IFDEF USE_WINDOW_MESSAGE}
postMessage(FMSGWin,Msg,wParam,lParam);
{$ELSE}
EnterCriticalSection(FCtlSect);
try
FEventList.Add(nil);
PostThreadMessage(ThreadID,Msg,wParam,lParam);
finally
LeaveCriticalSection(FCtlSect);
end;
{$ENDIF}
end;
{------------------------------------------------------------------------------}
procedure TMsgThread.SendMsg(Msg: Cardinal; wParam, lParam: Integer);
{$IFNDEF USE_WINDOW_MESSAGE}
var
aEvent:PHandle;
{$ENDIF}
begin
{$IFDEF USE_WINDOW_MESSAGE}
SendMessage(FMSGWin,Msg,wParam,lParam);
{$ELSE}
EnterCriticalSection(FCtlSect);
try
New(aEvent);
aEvent^ := CreateEvent(nil, True, False, nil);
FEventList.Add(aEvent);
PostThreadMessage(ThreadID,Msg,wParam,lParam);
finally
LeaveCriticalSection(FCtlSect);
end;
WaitForSingleObject(aEvent^,INFINITE);
{$ENDIF}
end;
end.
我参考了一下msdn,还有windows核心编程. 写了一个类来封装这个功能,不知道对不对.
里面使用了两个方法,一个使用一个隐含窗体来处理消息
还有一个是直接使用thread的消息队列来处理,但是这个时候sendmessage无法工作,
所以我自己设想了一个方法,虽然不完全达到了要求但是我简单测试了一下,好像还能工作.
切换两种工作方式要修改编译条件
{$DEFINE USE_WINDOW_MESSAGE} 使用隐含窗体来处理消息
{-$DEFINE USE_WINDOW_MESSAGE} 使用线程消息队列来处理消息
还有我想要等待线程开始进行消息循环的时候create函数才返回.
但是现在好像还没有这样(用一个事件来处理).只是开始进入了threadexecute函数,线程的create就返回了.可能会出问题.
通过设置 DoLoop属性可以设定线程是否循环(不阻塞等待消息),这样派生类线程在循环做一些其他事情的同时还可以接受消息. 例如:
派生类里面循环发送缓冲区的数据,还可以响应其他线程发送过来的消息(如停止,启动,退出,等等)
重新修改了一下，现在用起来基本没有问题了。
{ -----------------------------------------------------------------------------
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.
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:
1 unit Threading.CommThread;
2
3 interface
4
5 uses
6 Classes, SysUtils, ExtCtrls, SyncObjs, Generics.Collections, DateUtils;
7
8 const
9 CTID_USER = 1000;
10 PRM_USER = 1000;
11
12 CTID_STATUS = 1;
13 CTID_PROGRESS = 2;
14
15 type
16 TThreadParams = class(TDictionary<String, Variant>);
17 TThreadObjects = class(TDictionary<String, TObject>);
18
19 TCommThreadParams = class(TObject)
20 private
21 FThreadParams: TThreadParams;
22 FThreadObjects: TThreadObjects;
23 public
24 constructor Create;
25 destructor Destroy; override;
26
27 procedure Clear;
28
29 function GetParam(const ParamName: String): Variant;
30 function SetParam(const ParamName: String; ParamValue: Variant): TCommThreadParams;
31 function GetObject(const ObjectName: String): TObject;
32 function SetObject(const ObjectName: String; Obj: TObject): TCommThreadParams;
33 end;
34
35 TCommQueueItem = class(TObject)
36 private
37 FSender: TObject;
38 FMessageId: Integer;
39 FCommThreadParams: TCommThreadParams;
40 public
41 destructor Destroy; override;
42
43 property Sender: TObject read FSender write FSender;
44 property MessageId: Integer read FMessageId write FMessageId;
45 property CommThreadParams: TCommThreadParams read FCommThreadParams write FCommThreadParams;
46 end;
47
48 TCommQueue = class(TQueue<TCommQueueItem>);
49
50 ICommDispatchReceiver = interface
51 ['{A4E2C9D1-E4E8-497D-A9BF-FAFE2D3A7C49}']
52 procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
53 procedure CommThreadTerminated(Sender: TObject);
54 function Cancelled: Boolean;
55 end;
56
57 TCommThread = class(TThread)
58 protected
59 FCommThreadParams: TCommThreadParams;
60 FCommDispatchReceiver: ICommDispatchReceiver;
61 FName: String;
62 FProgressFrequency: Integer;
63 FNextSendTime: TDateTime;
64
65 procedure SendStatusMessage(const StatusText: String; StatusType: Integer = 0); virtual;
66 procedure SendProgressMessage(ProgressID: Int64; Progress, ProgressMax: Integer; AlwaysSend: Boolean = TRUE); virtual;
67 public
68 constructor Create(CommDispatchReceiver: TObject); reintroduce; virtual;
69 destructor Destroy; override;
70
71 function SetParam(const ParamName: String; ParamValue: Variant): TCommThread;
72 function GetParam(const ParamName: String): Variant;
73 function SetObject(const ObjectName: String; Obj: TObject): TCommThread;
74 function GetObject(const ObjectName: String): TObject;
75 procedure SendCommMessage(MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;
76
77 property Name: String read FName;
78 end;
79
80 TCommThreadClass = Class of TCommThread;
81
82 TCommThreadQueue = class(TObjectList<TCommThread>);
83
84 TCommThreadDispatchState = (
85 ctsIdle,
86 ctsActive,
87 ctsTerminating
88 );
89
90 TOnReceiveThreadMessage = procedure(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams) of object;
91 TOnStateChange = procedure(Sender: TObject; State: TCommThreadDispatchState) of object;
92 TOnStatus = procedure(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer) of object;
93 TOnProgress = procedure(Source, Sender: TObject; const ID: String; Progress, ProgressMax: Integer) of object;
94
95 TBaseCommThreadDispatch = class(TComponent, ICommDispatchReceiver)
96 private
97 FProcessQueueTimer: TTimer;
98 FCSReceiveMessage: TCriticalSection;
99 FCSCommThreads: TCriticalSection;
100 FCommQueue: TCommQueue;
101 FActiveThreads: TList;
102 FCommThreadClass: TCommThreadClass;
103 FCommThreadDispatchState: TCommThreadDispatchState;
104
105 function CreateThread(const ThreadName: String = ''): TCommThread;
106 function GetActiveThreadCount: Integer;
107 function GetStateText: String;
108 protected
109 FOnReceiveThreadMessage: TOnReceiveThreadMessage;
110 FOnStateChange: TOnStateChange;
111 FOnStatus: TOnStatus;
112 FOnProgress: TOnProgress;
113 FManualMessageQueue: Boolean;
114 FProgressFrequency: Integer;
115
116 procedure SetManualMessageQueue(const Value: Boolean);
117 procedure SetProcessQueueTimerInterval(const Value: Integer);
118 procedure SetCommThreadDispatchState(const Value: TCommThreadDispatchState);
119 procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
120 procedure OnProcessQueueTimer(Sender: TObject);
121 function GetProcessQueueTimerInterval: Integer;
122
123 procedure CommThreadTerminated(Sender: TObject); virtual;
124 function Finished: Boolean; virtual;
125
126 procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;
127 procedure DoOnStateChange; virtual;
128
129 procedure TerminateActiveThreads;
130
131 property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
132 property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
133 property OnStatus: TOnStatus read FOnStatus write FOnStatus;
134 property OnProgress: TOnProgress read FOnProgress write FOnProgress;
135
136 property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
137 property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
138 property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
139 property CommThreadDispatchState: TCommThreadDispatchState read FCommThreadDispatchState write SetCommThreadDispatchState;
140 public
141 constructor Create(AOwner: TComponent); override;
142 destructor Destroy; override;
143
144 function NewThread(const ThreadName: String = ''): TCommThread; virtual;
145 procedure ProcessMessageQueue; virtual;
146 procedure Stop; virtual;
147 function State: TCommThreadDispatchState;
148 function Cancelled: Boolean;
149
150 property ActiveThreadCount: Integer read GetActiveThreadCount;
151 property StateText: String read GetStateText;
152
153 property CommThreadClass: TCommThreadClass read FCommThreadClass write FCommThreadClass;
154 end;
155
156 TCommThreadDispatch = class(TBaseCommThreadDispatch)
157 published
158 property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
159 property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
160
161 property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
162 property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
163 property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
164 end;
165
166 TBaseStatusCommThreadDispatch = class(TBaseCommThreadDispatch)
167 protected
168 FOnStatus: TOnStatus;
169 FOnProgress: TOnProgress;
170
171 procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); override;
172
173 procedure DoOnStatus(Sender: TObject;const ID: String; const StatusText: String; StatusType: Integer); virtual;
174 procedure DoOnProgress(Sender: TObject; const ID: String; Progress, ProgressMax: Integer); virtual;
175
176 property OnStatus: TOnStatus read FOnStatus write FOnStatus;
177 property OnProgress: TOnProgress read FOnProgress write FOnProgress;
178 end;
179
180 TStatusCommThreadDispatch = class(TBaseStatusCommThreadDispatch)
181 published
182 property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
183 property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
184 property OnStatus: TOnStatus read FOnStatus write FOnStatus;
185 property OnProgress: TOnProgress read FOnProgress write FOnProgress;
186
187 property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
188 property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
189 property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
190 end;
191
192 implementation
193
194 const
195 PRM_STATUS_TEXT = 'Status';
196 PRM_STATUS_TYPE = 'Type';
197 PRM_PROGRESS_ID = 'ProgressID';
198 PRM_PROGRESS = 'Progess';
199 PRM_PROGRESS_MAX = 'ProgressMax';
200
201 resourcestring
202 StrCommReceiverMustSupportInterface = 'CommDispatchReceiver must support ICommDispatchReceiver interface';
203 StrSenderMustBeATCommThread = 'Sender must be a TCommThread';
204 StrUnableToFindTerminatedThread = 'Unable to find the terminated thread';
205 StrIdle = 'Idle';
206 StrTerminating = 'Terminating';
207 StrActive = 'Active';
208
209 { TCommThread }
210
211 constructor TCommThread.Create(CommDispatchReceiver: TObject);
212 begin
213 Assert(Supports(CommDispatchReceiver, ICommDispatchReceiver, FCommDispatchReceiver), StrCommReceiverMustSupportInterface);
214
215 inherited Create(TRUE);
216
217 FCommThreadParams := TCommThreadParams.Create;
218 end;
219
220 destructor TCommThread.Destroy;
221 begin
222 FCommDispatchReceiver.CommThreadTerminated(Self);
223
224 FreeAndNil(FCommThreadParams);
225
226 inherited;
227 end;
228
229 function TCommThread.GetObject(const ObjectName: String): TObject;
230 begin
231 Result := FCommThreadParams.GetObject(ObjectName);
232 end;
233
234 function TCommThread.GetParam(const ParamName: String): Variant;
235 begin
236 Result := FCommThreadParams.GetParam(ParamName);
237 end;
238
239 procedure TCommThread.SendCommMessage(MessageId: Integer;
240 CommThreadParams: TCommThreadParams);
241 begin
242 FCommDispatchReceiver.QueueMessage(Self, MessageId, CommThreadParams);
243 end;
244
245 procedure TCommThread.SendProgressMessage(ProgressID: Int64; Progress,
246 ProgressMax: Integer; AlwaysSend: Boolean);
247 begin
248 if (AlwaysSend) or (now > FNextSendTime) then
249 begin
250 // Send a status message to the comm receiver
251 SendCommMessage(CTID_PROGRESS, TCommThreadParams.Create
252 .SetParam(PRM_PROGRESS_ID, ProgressID)
253 .SetParam(PRM_PROGRESS, Progress)
254 .SetParam(PRM_PROGRESS_MAX, ProgressMax));
255
256 if not AlwaysSend then
257 FNextSendTime := now + (FProgressFrequency * OneMillisecond);
258 end;
259 end;
260
261 procedure TCommThread.SendStatusMessage(const StatusText: String;
262 StatusType: Integer);
263 begin
264 // Send a status message to the comm receiver
265 SendCommMessage(CTID_STATUS, TCommThreadParams.Create
266 .SetParam(PRM_STATUS_TEXT, StatusText)
267 .SetParam(PRM_STATUS_TYPE, StatusType));
268 end;
269
270 function TCommThread.SetObject(const ObjectName: String;
271 Obj: TObject): TCommThread;
272 begin
273 Result := Self;
274
275 FCommThreadParams.SetObject(ObjectName, Obj);
276 end;
277
278 function TCommThread.SetParam(const ParamName: String;
279 ParamValue: Variant): TCommThread;
280 begin
281 Result := Self;
282
283 FCommThreadParams.SetParam(ParamName, ParamValue);
284 end;
285
286
287 { TCommThreadDispatch }
288
289 function TBaseCommThreadDispatch.Cancelled: Boolean;
290 begin
291 Result := State = ctsTerminating;
292 end;
293
294 procedure TBaseCommThreadDispatch.CommThreadTerminated(Sender: TObject);
295 var
296 idx: Integer;
297 begin
298 FCSCommThreads.Enter;
299 try
300 Assert(Sender is TCommThread, StrSenderMustBeATCommThread);
301
302 // Find the thread in the active thread list
303 idx := FActiveThreads.IndexOf(Sender);
304
305 Assert(idx <> -1, StrUnableToFindTerminatedThread);
306
307 // if we find it, remove it (we should always find it)
308 FActiveThreads.Delete(idx);
309 finally
310 FCSCommThreads.Leave;
311 end;
312 end;
313
314 constructor TBaseCommThreadDispatch.Create(AOwner: TComponent);
315 begin
316 inherited;
317
318 FCommThreadClass := TCommThread;
319
320 FProcessQueueTimer := TTimer.Create(nil);
321 FProcessQueueTimer.Enabled := FALSE;
322 FProcessQueueTimer.Interval := 5;
323 FProcessQueueTimer.OnTimer := OnProcessQueueTimer;
324 FProgressFrequency := 200;
325
326 FCommQueue := TCommQueue.Create;
327
328 FActiveThreads := TList.Create;
329
330 FCSReceiveMessage := TCriticalSection.Create;
331 FCSCommThreads := TCriticalSection.Create;
332 end;
333
334 destructor TBaseCommThreadDispatch.Destroy;
335 begin
336 // Stop the queue timer
337 FProcessQueueTimer.Enabled := FALSE;
338
339 TerminateActiveThreads;
340
341 // Pump the queue while there are active threads
342 while CommThreadDispatchState <> ctsIdle do
343 begin
344 ProcessMessageQueue;
345
346 sleep(10);
347 end;
348
349 // Free everything
350 FreeAndNil(FProcessQueueTimer);
351 FreeAndNil(FCommQueue);
352 FreeAndNil(FCSReceiveMessage);
353 FreeAndNil(FCSCommThreads);
354 FreeAndNil(FActiveThreads);
355
356 inherited;
357 end;
358
359 procedure TBaseCommThreadDispatch.DoOnReceiveThreadMessage(Sender: TObject;
360 MessageId: Integer; CommThreadParams: TCommThreadParams);
361 begin
362 // Don't send the messages if we're being destroyed
363 if not (csDestroying in ComponentState) then
364 begin
365 if Assigned(FOnReceiveThreadMessage) then
366 FOnReceiveThreadMessage(Self, Sender, MessageId, CommThreadParams);
367 end;
368 end;
369
370 procedure TBaseCommThreadDispatch.DoOnStateChange;
371 begin
372 if (Assigned(FOnStateChange)) and (not (csDestroying in ComponentState)) then
373 FOnStateChange(Self, FCommThreadDispatchState);
374 end;
375
376 function TBaseCommThreadDispatch.GetActiveThreadCount: Integer;
377 begin
378 Result := FActiveThreads.Count;
379 end;
380
381 function TBaseCommThreadDispatch.GetProcessQueueTimerInterval: Integer;
382 begin
383 Result := FProcessQueueTimer.Interval;
384 end;
385
386
387 function TBaseCommThreadDispatch.GetStateText: String;
388 begin
389 case State of
390 ctsIdle: Result := StrIdle;
391 ctsTerminating: Result := StrTerminating;
392 ctsActive: Result := StrActive;
393 end;
394 end;
395
396 function TBaseCommThreadDispatch.NewThread(const ThreadName: String): TCommThread;
397 begin
398 if FCommThreadDispatchState = ctsTerminating then
399 Result := nil
400 else
401 begin
402 // Make sure we're active
403 if CommThreadDispatchState = ctsIdle then
404 CommThreadDispatchState := ctsActive;
405
406 Result := CreateThread(ThreadName);
407
408 FActiveThreads.Add(Result);
409
410 if ThreadName = '' then
411 Result.FName := IntToStr(Integer(Result))
412 else
413 Result.FName := ThreadName;
414
415 Result.FProgressFrequency := FProgressFrequency;
416 end;
417 end;
418
419 function TBaseCommThreadDispatch.CreateThread(
420 const ThreadName: String): TCommThread;
421 begin
422 Result := FCommThreadClass.Create(Self);
423
424 Result.FreeOnTerminate := TRUE;
425 end;
426
427 procedure TBaseCommThreadDispatch.OnProcessQueueTimer(Sender: TObject);
428 begin
429 ProcessMessageQueue;
430 end;
431
432 procedure TBaseCommThreadDispatch.ProcessMessageQueue;
433 var
434 CommQueueItem: TCommQueueItem;
435 begin
436 if FCommThreadDispatchState in [ctsActive, ctsTerminating] then
437 begin
438 if FCommQueue.Count > 0 then
439 begin
440 FCSReceiveMessage.Enter;
441 try
442 CommQueueItem := FCommQueue.Dequeue;
443
444 while Assigned(CommQueueItem) do
445 begin
446 try
447 DoOnReceiveThreadMessage(CommQueueItem.Sender, CommQueueItem.MessageId, CommQueueItem.CommThreadParams);
448 finally
449 FreeAndNil(CommQueueItem);
450 end;
451
452 if FCommQueue.Count > 0 then
453 CommQueueItem := FCommQueue.Dequeue;
454 end;
455 finally
456 FCSReceiveMessage.Leave
457 end;
458 end;
459
460 if Finished then
461 begin
462 FCommThreadDispatchState := ctsIdle;
463
464 DoOnStateChange;
465 end;
466 end;
467 end;
468
469 function TBaseCommThreadDispatch.Finished: Boolean;
470 begin
471 Result := FActiveThreads.Count = 0;
472 end;
473
474 procedure TBaseCommThreadDispatch.QueueMessage(Sender: TObject; MessageId: Integer;
475 CommThreadParams: TCommThreadParams);
476 var
477 CommQueueItem: TCommQueueItem;
478 begin
479 FCSReceiveMessage.Enter;
480 try
481 CommQueueItem := TCommQueueItem.Create;
482 CommQueueItem.Sender := Sender;
483 CommQueueItem.MessageId := MessageId;
484 CommQueueItem.CommThreadParams := CommThreadParams;
485
486 FCommQueue.Enqueue(CommQueueItem);
487 finally
488 FCSReceiveMessage.Leave
489 end;
490 end;
491
492 procedure TBaseCommThreadDispatch.SetCommThreadDispatchState(
493 const Value: TCommThreadDispatchState);
494 begin
495 if FCommThreadDispatchState <> ctsTerminating then
496 begin
497 if Value = ctsActive then
498 begin
499 if not FManualMessageQueue then
500 FProcessQueueTimer.Enabled := TRUE;
501 end
502 else
503 TerminateActiveThreads;
504 end;
505
506 FCommThreadDispatchState := Value;
507
508 DoOnStateChange;
509 end;
510
511 procedure TBaseCommThreadDispatch.SetManualMessageQueue(const Value: Boolean);
512 begin
513 FManualMessageQueue := Value;
514 end;
515
516 procedure TBaseCommThreadDispatch.SetProcessQueueTimerInterval(const Value: Integer);
517 begin
518 FProcessQueueTimer.Interval := Value;
519 end;
520
521 function TBaseCommThreadDispatch.State: TCommThreadDispatchState;
522 begin
523 Result := FCommThreadDispatchState;
524 end;
525
526 procedure TBaseCommThreadDispatch.Stop;
527 begin
528 if CommThreadDispatchState = ctsActive then
529 TerminateActiveThreads;
530 end;
531
532 procedure TBaseCommThreadDispatch.TerminateActiveThreads;
533 var
534 i: Integer;
535 begin
536 if FCommThreadDispatchState = ctsActive then
537 begin
538 // Lock threads
539 FCSCommThreads.Acquire;
540 try
541 FCommThreadDispatchState := ctsTerminating;
542
543 DoOnStateChange;
544
545 // Terminate each thread in turn
546 for i := 0 to pred(FActiveThreads.Count) do
547 TCommThread(FActiveThreads[i]).Terminate;
548 finally
549 FCSCommThreads.Release;
550 end;
551 end;
552 end;
553
554
555 { TCommThreadParams }
556
557 procedure TCommThreadParams.Clear;
558 begin
559 FThreadParams.Clear;
560 FThreadObjects.Clear;
561 end;
562
563 constructor TCommThreadParams.Create;
564 begin
565 FThreadParams := TThreadParams.Create;
566 FThreadObjects := TThreadObjects.Create;
567 end;
568
569 destructor TCommThreadParams.Destroy;
570 begin
571 FreeAndNil(FThreadParams);
572 FreeAndNil(FThreadObjects);
573
574 inherited;
575 end;
576
577 function TCommThreadParams.GetObject(const ObjectName: String): TObject;
578 begin
579 Result := FThreadObjects.Items[ObjectName];
580 end;
581
582 function TCommThreadParams.GetParam(const ParamName: String): Variant;
583 begin
584 Result := FThreadParams.Items[ParamName];
585 end;
586
587 function TCommThreadParams.SetObject(const ObjectName: String;
588 Obj: TObject): TCommThreadParams;
589 begin
590 FThreadObjects.AddOrSetValue(ObjectName, Obj);
591
592 Result := Self;
593 end;
594
595 function TCommThreadParams.SetParam(const ParamName: String;
596 ParamValue: Variant): TCommThreadParams;
597 begin
598 FThreadParams.AddOrSetValue(ParamName, ParamValue);
599
600 Result := Self;
601 end;
602
603 { TCommQueueItem }
604
605 destructor TCommQueueItem.Destroy;
606 begin
607 if Assigned(FCommThreadParams) then
608 FreeAndNil(FCommThreadParams);
609
610 inherited;
611 end;
612
613
614 { TBaseStatusCommThreadDispatch }
615
616 procedure TBaseStatusCommThreadDispatch.DoOnReceiveThreadMessage(
617 Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
618 begin
619 inherited;
620
621 case MessageId of
622 // Status Message
623 CTID_STATUS: DoOnStatus(Sender,
624 Name,
625 CommThreadParams.GetParam(PRM_STATUS_TEXT),
626 CommThreadParams.GetParam(PRM_STATUS_TYPE));
627 // Progress Message
628 CTID_PROGRESS: DoOnProgress(Sender,
629 CommThreadParams.GetParam(PRM_PROGRESS_ID),
630 CommThreadParams.GetParam(PRM_PROGRESS),
631 CommThreadParams.GetParam(PRM_PROGRESS_MAX));
632 end;
633 end;
634
635 procedure TBaseStatusCommThreadDispatch.DoOnStatus(Sender: TObject; const ID,
636 StatusText: String; StatusType: Integer);
637 begin
638 if (not (csDestroying in ComponentState)) and (Assigned(FOnStatus)) then
639 FOnStatus(Self, Sender, ID, StatusText, StatusType);
640 end;
641
642 procedure TBaseStatusCommThreadDispatch.DoOnProgress(Sender: TObject;
643 const ID: String; Progress, ProgressMax: Integer);
644 begin
645 if not (csDestroying in ComponentState) and (Assigned(FOnProgress)) then
646 FOnProgress(Self, Sender, ID, Progress, ProgressMax);
647 end;
648
649 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', '12345')
.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'); // 12345
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(0, TCommThreadParams.Create.SetParam('status', 'started')); for i := 0 to 40 do
begin
sleep(50); SendStatusMessage(format('Thread: %s, i = %d', [Name, i]), 1); if Terminated then
Break; sleep(50); SendProgressMessage(Integer(Self), i, 40, FALSE);
end; if Terminated then
SendCommMessage(0, TCommThreadParams.Create.SetParam('status', 'terminated'))
else
SendCommMessage(0, 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 := 0 to 29 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 = 0 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 = 0
Top = 0
Caption = 'CommThread Test'
ClientHeight = 290
ClientWidth = 557
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
AlignWithMargins = True
Left = 3
Top = 3
Width = 97
Height = 265
Margins.Right = 0
Align = alLeft
BevelOuter = bvNone
TabOrder = 0
object btnStop: TButton
AlignWithMargins = True
Left = 0
Top = 60
Width = 97
Height = 25
Margins.Left = 0
Margins.Top = 10
Margins.Right = 0
Margins.Bottom = 0
Align = alTop
Caption = 'Stop'
TabOrder = 2
OnClick = btnStopClick
end
object btnNewThread: TButton
Left = 0
Top = 0
Width = 97
Height = 25
Align = alTop
Caption = 'New Thread'
TabOrder = 0
OnClick = Button4Click
end
object btn30NewThreads: TButton
Left = 0
Top = 25
Width = 97
Height = 25
Align = alTop
Caption = '30 New Threads'
TabOrder = 1
OnClick = Button3Click
end
end
object lvLog: TListView
AlignWithMargins = True
Left = 103
Top = 3
Width = 451
Height = 265
Align = alClient
Columns = <
item
Caption = 'Message ID'
Width = 70
end
item
AutoSize = True
Caption = 'Info'
end>
ReadOnly = True
RowSelect = True
TabOrder = 1
ViewStyle = vsReport
end
object StatusBar1: TStatusBar
Left = 0
Top = 271
Width = 557
Height = 19
Panels = <>
SimplePanel = True
end
object tmrUpdateStatusBar: TTimer
Interval = 200
OnTimer = tmrUpdateStatusBarTimer
Left = 272
Top = 152
end
end
http://www.cnblogs.com/shangdawei/p/4015682.html