unit QueThread; interface uses Windows, Messages, SysUtils, Classes, SyncObjs; resourcestring TAKE_MESSAGE_FAULT = 'Unable to get next message fo thread %s'; THREAD_ERROR_CAUSED = 'An error caused in thread %s:'#13#10'%s'; UNKNOWN_EXCEPTION = 'Exception class %s cannot be handled'#13#10'Thread will be terminated'; const TRM_BASE = WM_USER + 100; TRM_TERMINATE = TRM_BASE + 0; TRM_OBJECT = TRM_BASE + 1; TRM_SYNCHRONIZE = TRM_BASE + 2; TRM_MAX = TRM_BASE + 2048; type TObjectMessage = packed record Msg: cardinal; Data: longint; Obj: TObject; unused: longint; end;//of record TSynchronizeMessage = packed record Msg: cardinal; Event: THandle; unused: array[0..1] of longint; end;//of record type TThrMsgState = (tsClearingQueue, tsConstructing, tsWaitingMsg, tsPerformingMsg); TQueThread = class(TThread) private fCaption: string; fState: TThrMsgState; procedure SetCaption(const NewVal: string); procedure ErrorReport(const Msg: string); procedure CatchException(E: Exception); procedure TakeMessage(out Msg: TMessage); procedure PassMessage(var Msg: TMessage); procedure ProcessMessage; procedure ClearQueue; protected procedure Execute; override; procedure ProcessMessages; function Catch(E: Exception): boolean; virtual; procedure TRMTerminate(var Message: TMessage); message TRM_TERMINATE; procedure TRMObject(var Message: TObjectMessage); message TRM_OBJECT; procedure TRMSynchronize(var Message: TSynchronizeMessage); message TRM_SYNCHRONIZE; public constructor Create(CreateSuspended: boolean; const ACaption: string); function PostMessage(const Message: TMessage): boolean; function PostObject(AData: longint; AObj: TObject): boolean; function Synchronize(Timeout: cardinal = INFINITE): TWaitResult; property Caption: string read fCaption write SetCaption; property State: TThrMsgState read fState; end;//of class ETakeMessageFault = class(Exception); EThreadCriticalError = class(Exception); function MessageBox(Handle: THandle; const Text,Caption: string; MsgType: cardinal): integer; implementation { ### TQueThread ############################################################# } constructor TQueThread.Create(CreateSuspended: boolean; const ACaption: string); begin fState:=tsConstructing; fCaption:=ACaption; inherited Create(CreateSuspended); end; { ### private ### } procedure TQueThread.SetCaption(const NewVal: string); begin with TCriticalSection.Create do begin Enter; try fCaption:=NewVal; finally Leave; Free; end; end; end; procedure TQueThread.ErrorReport(const Msg: string); begin MessageBox(Handle,Format(THREAD_ERROR_CAUSED,[Caption,Msg]), 'Error :-o',IDOK or MB_ICONERROR); end; procedure TQueThread.CatchException(E: Exception); var C: boolean; begin try C:=false; try C:=Catch(E); finally if not C then ErrorReport(E.Message); end; except on X: Exception do ErrorReport(X.Message) end; end; procedure TQueThread.TakeMessage(out Msg: TMessage); var M: tagMSG; begin fState:=tsWaitingMsg; if longint(GetMessage(M,0,TRM_BASE,TRM_MAX)) <> -1 then begin Msg.Msg:=M.Message; Msg.WParam:=M.wParam; Msg.LParam:=M.lParam; end else begin raise ETakeMessageFault.Create(Format(TAKE_MESSAGE_FAULT,[Caption])); end; end; procedure TQueThread.PassMessage(var Msg: TMessage); begin fState:=tsPerformingMsg; Dispatch(Msg); end; procedure TQueThread.ProcessMessage; var Msg: TMessage; begin try TakeMessage(Msg); PassMessage(Msg); except on E: Exception do CatchException(E); end; end; procedure TQueThread.ClearQueue; var M: tagMSG; begin fState:=tsClearingQueue; while PeekMessage(M,ThreadID,TRM_BASE,TRM_MAX,PM_REMOVE) do if (M.message = TRM_OBJECT) then begin TObject(M.lParam).Free; end else if (M.message = TRM_SYNCHRONIZE) then begin CloseHandle(THandle(M.wParam)); end; end; { ### protected ### } procedure TQueThread.ProcessMessages; var Msg: tagMSG; begin while PeekMessage(Msg,ThreadID,TRM_BASE,TRM_MAX,PM_NOREMOVE) do ProcessMessage; end; function TQueThread.Catch(E: Exception): boolean; begin Result:=false; end; procedure TQueThread.Execute; begin try try while not Terminated do ProcessMessage; finally ClearQueue; end; except on E: TObject do begin ErrorReport(Format(UNKNOWN_EXCEPTION,[E.ClassType])); end; end; Terminate; end; procedure TQueThread.TRMTerminate(var Message: TMessage); begin Terminate; end; procedure TQueThread.TRMObject(var Message: TObjectMessage); begin FreeAndNil(Message.Obj); end; procedure TQueThread.TRMSynchronize(var Message: TSynchronizeMessage); begin SetEvent(Message.Event); CloseHandle(Message.Event); end; { ### public ### } function TQueThread.PostMessage(const Message: TMessage): boolean; begin if State <> tsClearingQueue then begin if ThreadID <> 0 then begin with Message do PostThreadMessage(ThreadID,Msg,wParam,lParam); Result:=true; end else begin Result:=false; end; end else begin Result:=false; end; end; function TQueThread.PostObject(AData: longint; AObj: TObject): boolean; var Msg: TObjectMessage; begin with Msg do begin Msg:=TRM_OBJECT; Data:=AData; Obj:=AObj; unused:=0; end; Result:=PostMessage(TMessage(Msg)); end; function TQueThread.Synchronize(Timeout: cardinal = INFINITE): TWaitResult; var Msg: TSynchronizeMessage; begin ZeroMemory(@Msg,sizeof(Msg)); Msg.Msg:=TRM_SYNCHRONIZE; Msg.Event:=CreateEvent(nil,true,false,''); ResetEvent(Msg.Event); PostMessage(TMessage(Msg)); case Windows.WaitForSingleObject(Msg.Event,Timeout) of WAIT_ABANDONED: Result:=wrAbandoned; WAIT_OBJECT_0: Result:=wrSignaled; WAIT_TIMEOUT: Result:=wrTimeout; WAIT_FAILED: Result:=wrError; else Result:=wrError; end;//of case end; { ############################################################################ } function MessageBox(Handle: THandle; const Text,Caption: string; MsgType: cardinal): integer; begin Result:=Windows.MessageBox(Handle,PChar(Text),PChar(Caption),MsgType) end; end.