umsgthread.pas

详细解析delphi多线程程序的开发方法

{-----------------------------------------------------------------------------
 Unit Name: uMsgThread
 Author:    xwing
 eMail :    [e-mail] ; MSN : [e-mail]
 Purpose:   Thread with message Loop
 History:
 2003-12-11 Add a sync mehthod for pass param 
 2003-12-8  keep use windows message method 
 2003-12-7  Modify WaitFor(Timeout) procedure, Modify SendMessage method,
            Remove Waitfor procedure, Add CreateThread, CloseThread Procedures.
 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}

uses
  Classes, windows, messages, forms, sysutils;

const
  NM_EXECPROC = $8FFF;
  NM_EXEC_MSGPROC =$8FFE;
  NM_FREESYNCWND = $8FFD;

type
  EMsgThreadErr = class(Exception);

  TMsgThread = class;

  TmtSyncMethod = procedure of object;

  TmtSyncMsgMethod = procedure(const obj: TMsgThread; var  Msg :TMessage) of object;

  TMsgThread = class
  private
    FWaitHandle : THandle;
    m_hThread: THandle;
    threadid: DWORD;
    FMethod: TmtSyncMethod;
    FCtlSect: TRTLCriticalSection;
    FWinName: string;
    FMSGWin: HWND;
    fSyncMsg:TMessage;
    fMsgMethod :TmtSyncMsgMethod;

    FException: Exception;
    fDoLoop: Boolean;
    fAutoFree: Boolean;

    procedure MSGWinProc(var Message: TMessage);
    procedure SetDoLoop(const Value: Boolean);
    procedure Execute;

  protected
    Msg: tagMSG;

    procedure HandleException;
    procedure DoHandleException; virtual;

    //Inherited the Method to process your own Message
    procedure DoProcessMsg(var Msg: TMessage); virtual;

    //if DoLoop = true then loop call 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);
    function SendMsg(Msg: Cardinal; wParam: Integer; lParam: Integer): Integer;

  public
    constructor Create(Loop: Boolean = False; ThreadName: string = '');
    destructor destroy; override;

    function CreateThread: Boolean;
    procedure CloseThread;
    
    // Return TRUE if the thread exists. FALSE otherwise
    function ThreadExists: BOOL;

    procedure Synchronize(syncMethod: TmtSyncMethod);overload;
    procedure Synchronize(syncMethod: TmtSyncMsgMethod);overload;

    //postMessage to Quit,and FreeNil(if AutoFree = true)
    procedure QuitThread;
    
    //Wait thread quit
    function WaitTimeOut(timeout: DWORD = 4000): Longword;//0 mean wait INFINITE;
    
    //just like Application.processmessage.
    procedure ProcessMessage;

    //enable thread loop, not waitfor message, just check it
    property DoLoop: Boolean read fDoLoop write SetDoLoop;
    property AutoFree: Boolean read fAutoFree Write fAutoFree;
    property ExceptionObj: Exception read FException;
    property AsyncMsg: TMessage read fSyncMsg;  //赋值之后调用Sync方法发送参数。
  end;

implementation

var
  MsgThreadSyncWindow : HWND;
  MsgThreadSyncWindowCound: Integer;

{Forward declare}
function SyncWindowProc(Window: HWND; Msg, wParam, lParam: Longint): Longint; stdcall;forward;

procedure CreateMsgThreadSyncWindow;
begin
  Assert(GetCurrentThreadId = MainThreadID);
  if MsgThreadSyncWindow = 0 then
  begin
    MsgThreadSyncWindow := CreateWindow('STATIC', 'SyncWindow', WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);
    SetWindowLong(MsgThreadSyncWindow, GWL_WNDPROC, dword(@SyncWindowProc));
  end;{if}
end;

{------------------------------------------------------------------------------}
procedure FreeMsgThreadSyncWindow;
begin
  Assert(GetCurrentThreadId = MainThreadID);
  if MsgThreadSyncWindowCound <> 0 then
    Exit;
  if MsgThreadSyncWindow <> 0 then
  begin
    DestroyWindow(MsgThreadSyncWindow);
    MsgThreadSyncWindow := 0;
    MsgThreadSyncWindowCound := 0;
  end;{if}
end;

{------------------------------------------------------------------------------}
{--Window method for execute synchro method--}
function SyncWindowProc(Window: HWND; Msg, wParam, lParam: Longint): Longint; stdcall;
var
  obj:TMsgThread;
begin
  case Msg of
    NM_EXECPROC:
    begin
      obj := TMsgThread(wParam);
      Result := Integer(False);      
      try
        obj.FMethod;
        Result := Integer(True);
      except
        raise EMsgThreadErr.Create('Execute syncyhread method ERROR!');
      end;{try}
    end;
    NM_EXEC_MSGPROC:
    begin
      obj := TMsgThread(wParam);
      Result := Integer(False);
      try
        obj.fMsgMethod(obj, obj.fSyncMsg);
        Result := Integer(True);
      except
        raise EMsgThreadErr.Create('Execute syncyhread method ERROR!');
      end;{try}
    end;
    NM_FREESYNCWND: begin
      FreeMsgThreadSyncWindow;
    end;
  else
    Result := DefWindowProc(Window, Msg, wParam, lParam);
  end;{case}
end;
{//////////////////////////////////////////////////////////////////////////////}
function msgThdInitialThreadProc(pv: Pointer): DWORD; stdcall;
var
  obj: TMsgThread;
begin
  obj := TMsgThread(pv);
  obj.execute;
  obj.m_hThread := 0;
  if obj.AutoFree then
    FreeAndNil(obj);
  Result := 0;
end;

{ TMsgThread }
{//////////////////////////////////////////////////////////////////////////////}
{running in main thread}
constructor TMsgThread.Create(Loop: Boolean; ThreadName: string);
begin
  if GetCurrentThreadId <> MainThreadID then
    raise EMsgThreadErr.Create('Must create the thread in main thread.');
  InitializeCriticalSection(fCtlSect);    
  if ThreadName <> '' then
    FWinName := ThreadName
  else
    FWinName := 'Thread Window';

  FDoLoop := Loop;
  fAutoFree:= True;
  //Create a Window for sync method if necessary
  InterlockedIncrement(MsgThreadSyncWindowCound);
  CreateMsgThreadSyncWindow;
end;

{------------------------------------------------------------------------------}
{Both}
destructor TMsgThread.destroy;
begin
  if ThreadExists then
  begin
    QuitThread;
    WaitTimeOut;
  end;
  //Free Sync Window if necessary
  if MsgThreadSyncWindowCound = 1 then
    PostMessage(MsgThreadSyncWindow, NM_FREESYNCWND, 0, 0);
  InterlockedDecrement(MsgThreadSyncWindowCound);
  DeleteCriticalSection(FCtlSect);  
  inherited;
end;

{//////////////////////////////////////////////////////////////////////////////}
procedure TMsgThread.Execute;
var
  mRet: Boolean;
  aRet: Boolean;
begin
  FMSGWin := CreateWindow('STATIC', PChar(FWinName), WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);
  SetWindowLong(FMSGWin, GWL_WNDPROC, Longint(MakeObjectInstance(MSGWinProc)));
  PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE); //Force system to alloc a msgQueue
  //notify thread created.
  SetEvent(FWaitHandle);
  CloseHandle(FWaitHandle);

  mRet := True;
  try
    DoInit;
    while mRet do //Message Loop
    begin
      if fDoLoop then
      begin
        while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
        begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
        end;{while}
        if Msg.message = WM_QUIT then
          mRet := False
        else
          DoMsgLoop;
      end{if}
      else begin
        mRet := GetMessage(Msg, 0, 0, 0);
        if mRet then
        begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
        end;{if}
      end;{else}
    end;{while}
    DoUnInit;
    FreeObjectInstance(Pointer(GetWindowLong(FMSGWin, GWL_WNDPROC)));
    DestroyWindow(FMSGWin);
    FMSGWin := 0;
  except
    HandleException;
  end;{try}
end;

{------------------------------------------------------------------------------}
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;

{------------------------------------------------------------------------------}
{runing in main thread}
procedure TMsgThread.DoHandleException;
begin
  if FException is Exception then
    Application.ShowException(FException)
  else
    SysUtils.ShowException(FException, nil);
end;

{//////////////////////////////////////////////////////////////////////////////}
{Message process , running in the thread}
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;

procedure TMsgThread.DoProcessMsg(var Msg: TMessage);
begin
end;

{------------------------------------------------------------------------------}
{should call in the thread!}
procedure TMsgThread.ProcessMessage;
begin
  while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
  begin
    TranslateMessage(Msg);
    DispatchMessage(Msg);
    if Msg.message = WM_QUIT then
      Break;
  end;{while}
end;

{//////////////////////////////////////////////////////////////////////////////}
{running in the thread}
procedure TMsgThread.DoInit;
begin
end;

procedure TMsgThread.DoUnInit;
begin
end;

procedure TMsgThread.DoMsgLoop;
begin
  Sleep(1);
end;

{//////////////////////////////////////////////////////////////////////////////}
{both}
function TMsgThread.ThreadExists: BOOL;
begin
  if m_hThread = 0 then
    Result := false
  else
    Result := True;
end;

{------------------------------------------------------------------------------}
{both}
procedure TMsgThread.QuitThread;
begin
  if FMSGWin <> 0 then
    PostMessage(FMSGWin, WM_QUIT, 0, 0);
end;

{------------------------------------------------------------------------------}
procedure TMsgThread.SetDoLoop(const Value: Boolean);
begin
  if not ThreadExists then
    Exit;
  if Value = fDoLoop then
    Exit;
  fDoLoop := Value;
  {post a message to active the message loop}
  if fDoLoop then
    PostMsg(WM_USER, 0, 0);
end;

{------------------------------------------------------------------------------}
{Wait thread to quit, call out of the thread}
function TMsgThread.WaitTimeOut(timeout: dword): Longword;
var
  H: THandle;
  t:DWORD;
begin
  EnterCriticalSection(FCtlSect);
  try
    H := m_hThread;// InterlockedExchange(Integer(m_hThread), 0);
    if timeout = 0 then
      t := INFINITE;
    repeat
      case MsgWaitForMultipleObjects(1, H, False, t,
        QS_POSTMESSAGE or QS_SENDMESSAGE or QS_ALLPOSTMESSAGE) of

        WAIT_OBJECT_0:  //Thread Quit.
          Break;
        WAIT_OBJECT_0 + 1:  //New Message
          Application.ProcessMessages;
        WAIT_TIMEOUT: begin
          TerminateThread(h, 0);
          Break;
        end;
      end;{case}
    until False;
  finally
    LeaveCriticalSection(FCtlSect);
  end;    
  GetExitCodeThread(H, Result);
end;

{------------------------------------------------------------------------------}
{both}
procedure TMsgThread.PostMsg(Msg: Cardinal; wParam, lParam: Integer);
begin
  if not ThreadExists then
    Exit;
  postMessage(FMSGWin, Msg, wParam, lParam);
end;

{------------------------------------------------------------------------------}
{both}
function TMsgThread.SendMsg(Msg: Cardinal; wParam, lParam: Integer): Integer;
begin
  Result := Integer(False);
  if not ThreadExists then
    Exit;
  Result := SendMessage(FMSGWin, Msg, wParam, lParam);
end;

{------------------------------------------------------------------------------}
{--Call in the thread--}
procedure TMsgThread.Synchronize(syncMethod: TmtSyncMethod);
begin
  if not ThreadExists then
    Exit;
  FMethod := syncMethod;
  SendMessage(MsgThreadSyncWindow, NM_EXECPROC, Longint(Self), 0);
end;

{------------------------------------------------------------------------------}
{调用之前，应该先给SyncMsg参数赋值}
procedure TMsgThread.Synchronize(syncMethod: TmtSyncMsgMethod);
begin
  if not ThreadExists then
    Exit;
  SendMessage(MsgThreadSyncWindow, NM_EXECPROC, Longint(Self), 0);
end;

{------------------------------------------------------------------------------}
{running out of the thread}
function TMsgThread.CreateThread: Boolean;
begin
  EnterCriticalSection(FCtlSect);
  try
  if ThreadExists then
    Exit;
    //raise EMsgThreadErr.Create('Thread already exists, when create thread.');
  FWaitHandle := CreateEvent(nil, True, False, nil);
  m_hThread := windows.CreateThread(nil, 0, @msgThdInitialThreadProc, Self, 0, threadid);
  if m_hThread = 0 then
    Result := False
  else
    Result := True;
  //Wait until thread Message Loop started
  WaitForSingleObject(FWaitHandle,INFINITE);
  finally
    LeaveCriticalSection(FCtlSect);
  end;
end;

{------------------------------------------------------------------------------}
{running out of the thread}
procedure TMsgThread.CloseThread;
begin
  if not ThreadExists then
    Exit;
  QuitThread;
  WaitTimeOut(0);
  m_hThread := 0;
end;

{//////////////////////////////////////////////////////////////////////////////}
initialization
finalization
  FreeMsgThreadSyncWindow;

end.