{ Public Domain }
unit MessageThread;

interface

uses Windows, Messages, SysUtils, Classes, SyncObjs;

type
  { Thread supporting messages. Note: TMessageThread must be instantiated from
    the main-thread only. }
  TMessageThread = class
  private
    FHandle: THandle;
    FEvent: TEvent;
    FThread: TThread;
    FTerminated: Boolean;
    FInstance: Pointer;
    FObject: TObject;
    function GetThreadHandle: THandle;
    procedure WndProc(var Message: TMessage);
    procedure Execute;
  protected
    procedure BeforeExecute; virtual;
    procedure AfterExecute; virtual;
    procedure HandleException(E: Exception); virtual;
    procedure Synchronize(AMethod: TThreadMethod);
    procedure Queue(AMethod: TThreadMethod);
  public
    constructor Create;
    destructor Destroy; override;
    property DispatchObject: TObject read FObject write FObject;
    procedure Terminate;
    property Handle: THandle read FHandle;
    property ThreadHandle: THandle read GetThreadHandle;
  end;

implementation

uses Contnrs;

type
  THelperThread = class(TThread)
  private
    FMessageThread: TMessageThread;
  protected
    procedure Execute; override;
    procedure Synchronize(AMethod: TThreadMethod); reintroduce; inline;
    procedure Queue(AMethod: TThreadMethod); reintroduce; inline; 
  end;

procedure THelperThread.Execute;
begin
  FMessageThread.Execute;
end;

{ THelperThread }

procedure THelperThread.Queue(AMethod: TThreadMethod);
begin
  inherited Queue(AMethod);
end;

procedure THelperThread.Synchronize(AMethod: TThreadMethod);
begin
  inherited Synchronize(AMethod);
end;

{ TMessageThread }

procedure TMessageThread.AfterExecute;
begin

end;

procedure TMessageThread.BeforeExecute;
begin

end;

constructor TMessageThread.Create;
begin
  inherited;
  Assert(GetCurrentThreadId = MainThreadID);
  FInstance := MakeObjectInstance(WndProc); // not thread-safe
  FEvent := TEvent.Create(nil, False, False, '');
  FThread := THelperThread.Create(True);
  THelperThread(FThread).FMessageThread := Self;
  FThread.Resume;
  FEvent.WaitFor(INFINITE); // make sure FHandle is valid before leaving
end;

destructor TMessageThread.Destroy;
begin
  Terminate;
  FEvent.SetEvent; // allow thread to release FHandle
  FThread.Free;
  FEvent.Free;
  if FInstance <> nil then
    FreeObjectInstance(FInstance); // not thread-safe
  inherited;
end;

procedure TMessageThread.Execute;
var
  Msg: TMsg;
  OrigWndProc: Pointer;
begin
  FHandle := Classes.AllocateHWnd(nil); // only thread-safe with nil parameter
  OrigWndProc := Pointer(GetWindowLong(FHandle, GWL_WNDPROC));
  SetWindowLong(FHandle, GWL_WNDPROC, Longint(FInstance));
  try
    FEvent.SetEvent; // signal that FHandle is set
    try
      BeforeExecute;
      try
        while not FTerminated do
        begin
          try
            if not GetMessage(Msg, 0, 0, 0) then
              break;
            TranslateMessage(Msg);
            DispatchMessage(Msg);
          except
            on E: Exception do
              HandleException(E);
          end;
        end;
      finally
        AfterExecute;
      end;
    finally
      FEvent.WaitFor(INFINITE); // wait before releasing FHandle
    end;
  finally
    SetWindowLong(FHandle, GWL_WNDPROC, Longint(OrigWndProc));
    Classes.DeallocateHWnd(FHandle);
  end;
end;

function TMessageThread.GetThreadHandle: THandle;
begin
  Result := FThread.Handle;
end;

procedure TMessageThread.HandleException(E: Exception);
  procedure ShowException(E: Exception);
  var
    Msg: string;
  begin
    Msg := E.Message;
    if (Msg <> '') and (AnsiLastChar(Msg) > '.') then
      Msg := Msg + '.';
    MessageBox(0, PChar(Msg), PChar(''), MB_OK + MB_ICONSTOP);
  end;
begin
  if not (E is EAbort) then
    ShowException(E);
end;

procedure TMessageThread.Queue(AMethod: TThreadMethod);
begin
  THelperThread(FThread).Queue(AMethod);
end;

procedure TMessageThread.Synchronize(AMethod: TThreadMethod);
begin
  THelperThread(FThread).Synchronize(AMethod);
end;

procedure TMessageThread.Terminate;
begin
  FTerminated := True;
  if FHandle <> 0 then
    PostMessage(FHandle, WM_NULL, 0, 0); // wake up thread
end;

procedure TMessageThread.WndProc(var Message: TMessage);
begin
  if FObject = nil then
    Dispatch(Message)
  else
    FObject.Dispatch(Message);
end;

end.