unit WThread;
// модуль для работы с доп.потоками
// позволяет "общаться" дополнительному и основному потокам посредством системной очереди сообщений
// без вызова синхронизации
// (c) wadman 2013

// использование:
// 1. Создать наследника с объявленными обработчиками сообщений между WM_THREAD_BASE и WM_THREAD_MAX
//     пример: procedure WMTestProc(var Msg: TMessage); message WM_TEST_PROC;
// 2. Присвоить обработчика(ов) события OnThreadReceiveMessage, OnTimeOut - при необходимости
// Для обмена строками рекомендууется использовать функции NewString и FreeString

interface

uses
    Classes,
    Windows,
    Messages,
    SysUtils;

const
    WM_THREAD_BASE      = WM_USER + $110;
    WM_THREAD_MAX       = WM_USER + $7FFF;

type
    TWThread = class;

    // событие на получение сообщения из потока
    TWThreadReceiveMessage = procedure(Sender: TWThread; var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM) of object;
    // событие из потока на таймаут
    TWThreadTimeOut = procedure(Sender: TWThread) of object;

    TWThread = class(TThread)
    private
        FToolWindow: THandle;
        hCloseEvent: THandle;
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FTimeOut: Cardinal;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        procedure SetTimeOut(const Value: Cardinal);
    protected
        procedure WWindowProc(var Msg: TMessage);
        // отправка сообщения из этого потока для вызова обрабочика OnThreadReceiveMessage
        procedure SendMessageFromMe(const Msg: Cardinal; const WParam: WPARAM; const LParam: LPARAM);
        procedure DoThreadReceiveMessage(var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM);
        procedure DoTimeout;
        procedure Execute; override;
    public
        constructor Create; overload;
        constructor Create(CreateSuspended: Boolean); overload;
        destructor Destroy; override;
        // см TimeOutIsDirect, при true - перекрыть следующую процедуру
        procedure DirectTimeOut; virtual;
        // отправка любого сообщения В этот поток
        function SendToThreadMessage(AMsg: UInt; wParam: WPARAM; lParam: LPARAM): BOOL;
        // остановка потока по феншую
        function StopThread: boolean;
        // событие на получение данных ИЗ этого потока, вызывается в основном потоке
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
        // событие, возникающее при превышении интервала ожидания
        property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
        // интервал ожидания в мс, по-умолчанию - бесконечно
        property TimeOut: Cardinal read FTimeOut write SetTimeOut default INFINITE;
        // true = Будет вызван DirectTimeOut из этого потока, false = вызвано событие OnTimeOut в основном потоке.
        property TimeOutIsDirect: boolean read FTimeOutIsDirect write FTimeOutIsDirect default false;
    end;

// подготовка строки к обмену между потоками
function NewString(const Text: string): LPARAM;

// возвращение строки к привывчному виду после приема из другого потока
function FreeString(var P: LPARAM): String;

implementation

const
    WM_MSG              = WM_USER+$100;
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);

function NewString(const Text: string): LPARAM;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: LPARAM): String;
begin
    LPARAM(Result) := P;
end;

{function FreeString(var P: LPARAM): String;
begin
    if LongBool(P) then begin
        SetLength(Result, Length(PChar(P)));
        Move(Pointer(P)^, Pointer(Result)^, Length(Result)*SizeOfChar);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): LPARAM;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > 0 then begin
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        if LongBool(Result) then
            Move(Pointer(Text)^, Pointer(Result)^, l);
    end else
        Result := 0;
end;    }

{ TWThread }

constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited;
    FToolWindow := AllocateHWnd(WWindowProc);
    hCloseEvent := CreateEvent(nil, true, false, nil);
    FTimeOut := INFINITE;
    FTimeOutIsDirect := False;
end;

constructor TWThread.Create;
begin
    Create(False);
end;

destructor TWThread.Destroy;
begin
    CloseHandle(hCloseEvent);
    DeallocateHWnd(FToolWindow);
    inherited;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
end;

procedure TWThread.DoThreadReceiveMessage(var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM);
begin
    if Assigned(FOnThreadReceiveMessage) then
        FOnThreadReceiveMessage(Self, Msg, WParam, LParam);
end;

procedure TWThread.DoTimeout;
begin
    if Assigned(FOnTimeOut) then
        FOnTimeOut(Self);
end;

function TWThread.SendToThreadMessage(AMsg: UInt; wParam: WPARAM; lParam: LPARAM): BOOL;
begin
    result := (not Suspended)and(PostThreadMessage(ThreadID, AMsg, wParam, lParam));
end;

procedure TWThread.SetTimeOut(const Value: Cardinal);
begin
    if FTimeOut <> Value then begin
        FTimeOut := Value;
        if not Suspended then
            PostThreadMessage(ThreadID, WM_TIMEOUT, Value, 0);
    end;
end;

procedure TWThread.Execute;
var
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;
    message: TMessage;

    MSWait: Cardinal;
Label
    EndOfThread;
begin
    // следующая строка должна быть всегда первой в процедуре, т.к. запускает очередь сообщений для потока
    PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
    HandlesToWaitFor[0] := hCloseEvent;
    // SleepEx не нужен, если подготовительный код до цикла while будет достаточно долго выполняться
    // уточняется опытным путем, иначе очередь сообщений потока не успеет запуститься и сообщения могут улететь в пустоту
    //SleepEx(20, true);

    MSWait := FTimeOut; // изменяя кол-во миллисекунд в MSWait можно организовать событие-таймер, см WAIT_TIMEOUT
                        // в данном случае установлено бесконечное ожидание любого события

    while not Terminated do begin
        if not PeekMessage(msg, 0, WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE) then begin
            dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLINPUT);
            case dwHandleSignaled of
                WAIT_OBJECT_0: begin // выставлено событие остановки потока
                    if not FreeOnTerminate then
                        Terminate;
                    goto EndOfThread;
                end;
                WAIT_OBJECT_0 + 1: begin // получено сообщение
                    Continue;
                end;
                WAIT_TIMEOUT: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        SendMessageFromMe(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        if msg.hwnd <> 0 then begin
            TranslateMessage(msg);
            DispatchMessage(msg);
            Continue;
        end;
        case msg.message of
            WM_QUIT, WM_CLOSE, WM_DESTROY: begin // оконные сообщения тоже получаем
                if not FreeOnTerminate then
                    Terminate;
                goto EndOfThread;
            end;
            WM_TIMEOUT: begin
                MSWait := msg.wParam;
            end
            else begin
                message.Msg := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
    // все что создали в начале процедуры, здесь удаляем
end;

procedure TWThread.SendMessageFromMe(const Msg: Cardinal; const WParam: WPARAM; const LParam: LPARAM);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, Msg, WParam, LParam);
end;

function TWThread.StopThread: boolean;
begin
    SetEvent(hCloseEvent);
    SleepEx(1, false);
    Result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
end;

procedure TWThread.WWindowProc(var Msg: TMessage);
begin
    case Msg.Msg of
        WM_TIMEOUT: begin
            DoTimeout;
            Msg.Result := 1;
        end;
        WM_THREAD_BASE..WM_USER+WM_THREAD_MAX: begin
            DoThreadReceiveMessage(Msg.Msg, Msg.WParam, Msg.LParam);
            Msg.Result := 1;
        end
    else
        Msg.Result := DefWindowProc(FToolWindow, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;

end.

unit ThreadTestMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, WThread;

const
    WM_STRING   = WM_THREAD_BASE + 1;

type
    TMyThread = class(TWThread)
    private
        procedure ReceiveString(var Msg: TMessage); message WM_STRING;
    end;

  TfrmWThreadTest = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    FThread: TMyThread;
    procedure ReceiveMsg(Sender: TWThread; var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM);
    procedure StartThread;
    procedure StopThread;
  public
  end;

var
  frmWThreadTest: TfrmWThreadTest;

implementation

{$R *.dfm}

procedure TfrmWThreadTest.Button1Click(Sender: TObject);
begin
    if LongBool(FThread) then
        StopThread
    else
        StartThread;
end;

procedure TfrmWThreadTest.Button2Click(Sender: TObject);
var s: string;
begin
    if LongBool(FThread) and InputQuery('Input', 'Enter text', s) then begin
        // отправляем введенную строку в доп. поток
        Memo1.Lines.Add(Format('-> %s', [s]));
        FThread.SendToThreadMessage(WM_STRING, 0, NewString(s));
        s := '';
    end;
end;

procedure TfrmWThreadTest.FormClose(Sender: TObject; var Action: TCloseAction);
begin
    if LongBool(FThread) then
        StopThread;
end;

procedure TfrmWThreadTest.ReceiveMsg(Sender: TWThread; var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM);
begin
    case Msg of
        WM_STRING: begin
            Memo1.Lines.Add(Format('<- %s', [FreeString(LParam)]));
        end;
    end;
end;

procedure TfrmWThreadTest.StartThread;
begin
    if not LongBool(FThread) then begin
        FThread := TMyThread.Create(false);
        FThread.OnThreadReceiveMessage := ReceiveMsg;
    end;
end;

procedure TfrmWThreadTest.StopThread;
begin
    if LongBool(FThread) then begin
        if not FThread.StopThread then
            MessageDlg('You dont kill me!', mtError, [mbOk], 0);
        FThread.Free;
        FThread := nil;
    end;
end;

{ TMyThread }

procedure TMyThread.ReceiveString(var Msg: TMessage);
var s: string;
begin
    s := FreeString(Msg.LParam);
    // отправляем полученную строку обратно главному потоку
    SendMessageFromMe(Msg.Msg, Msg.WParam, NewString(s));
    sleep(5000);
    SendMessageFromMe(Msg.Msg, Msg.WParam, NewString(s));
end;

end.

unit WThread;

// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013

// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//     пример: procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
// 2. Присвоить обработчика(ов) события OnThreadReceiveMessage, OnTimeOut - при необходимости
// Для обмена строками рекомендууется использовать функции NewString и FreeString

{$IFDEF FPC}
{$mode objfpc}{$H+}
{$ENDIF}

interface

uses
    Classes, SyncObjs, Variants;

type
    PThreadMessage = ^TThreadMessage;
    TThreadMessage = record
        {$IFDEF FPC}
        Message: DWord;
        {$ELSE}
        Message: Word;
        {$ENDIF}
        WParam: Word;
        LParam: NativeInt;
    end;

    TWThread = class;

    TWThreadReceiveMessage = procedure(Sender: TWThread; Msg: TThreadMessage) of object;
    TWThreadTimeOut = procedure(Sender: TWThread) of object;

    { TWThread }

    TWThread = class(TThread)
    private
        FMessageEvent: TEvent;
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FOnTimeOut: TWThreadTimeOut;
        FQueue: TList;
        FSection: TCriticalSection;
        FTimeOut: Cardinal;
        FTimeOutIsDirect: boolean;
        FGUIThread: TThread;
        procedure SetTimeOut(AValue: Cardinal);
        procedure DoTimeOut;
    protected
        procedure Execute; override;
        {$IFDEF FPC}
        procedure SendGUIMessage(Message: DWord; WParam: Word; LParam: NativeInt);
        {$ELSE}
        procedure SendGUIMessage(Message: Word; WParam: Word; LParam: NativeInt);
        {$ENDIF}
    public
        constructor Create; overload;
        constructor Create(CreateSuspended: Boolean); overload;
        destructor Destroy; override;
        procedure DirectTimeOut; virtual;
        {$IFDEF FPC}
        procedure PostMessage(Message: DWord; WParam: Word; LParam: NativeInt);
        {$ELSE}
        procedure PostMessage(Message: Word; WParam: Word; LParam: NativeInt);
        {$ENDIF}
        procedure StopThread;
        // событие на получение данных ИЗ этого потока, вызывается в основном потоке
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
        // событие, возникающее при превышении интервала ожидания
        property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
        // интервал ожидания в мс, по-умолчанию - бесконечно
        property TimeOut: Cardinal read FTimeOut write SetTimeOut default INFINITE;
        // true = Будет вызван DirectTimeOut из этого потока, false = вызвано событие OnTimeOut в основном потоке.
        property TimeOutIsDirect: boolean read FTimeOutIsDirect write FTimeOutIsDirect default false;
    end;

// подготовка строки к обмену между потоками
function NewString(const Text: string): NativeInt;

// возвращение строки к привывчному виду после приема из другого потока
function FreeString(var P: NativeInt): String;

implementation

type

    { TGUIThread }

    TGUIThread = class(TThread)
    private
        FMessageEvent: TEvent;
        FTimeOut: Boolean;
        FOwner: TWThread;
        FQueue: TList;
        FSection: TCriticalSection;
        FCurrentMessage: TThreadMessage;
    protected
        procedure Execute; override;
        procedure CallGUIThread;
    public
        constructor Create(AOwner: TWThread); overload;
        destructor Destroy; override;
        {$IFDEF FPC}
        procedure PostMessage(Message: DWord; WParam: Word; LParam: NativeInt);
        {$ELSE}
        procedure PostMessage(Message: Word; WParam: Word; LParam: NativeInt);
        {$ENDIF}
        procedure StopThread;
    end;

function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    NativeInt(Result) := P;
end;

{function FreeString(var P: LPARAM): String;
begin
    if LongBool(P) then begin
        SetLength(Result, Length(PChar(P)));
        Move(Pointer(P)^, Pointer(Result)^, Length(Result)*SizeOfChar);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): LPARAM;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > 0 then begin
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        if LongBool(Result) then
            Move(Pointer(Text)^, Pointer(Result)^, l);
    end else
        Result := 0;
end;    }

{ TGUIThread }

procedure TGUIThread.Execute;
var Message: PThreadMessage;
    wr: TWaitResult;
begin
    while not Terminated do begin
        wr := FMessageEvent.WaitFor(INFINITE);
        if (not Terminated) and (wr = wrSignaled) then begin
            if FTimeOut then begin
                FTimeOut := False;
                if Assigned(FOwner.FOnTimeOut) then
                    FOwner.FOnTimeOut(FOwner);
            end;
            while FQueue.Count > 0 do begin
                FSection.Enter;
                Message := FQueue[0];
                FQueue.Delete(0);
                FSection.Leave;
                FCurrentMessage := Message^;
                //Move(Message^, FCurrentMessage, SizeOf(FCurrentMessage));
                FreeMem(Message);
                {$IFDEF FPC}
                Synchronize(@CallGUIThread);
                {$ELSE}
                Synchronize(CallGUIThread);
                {$ENDIF}
            end;
        end;
    end;
end;

procedure TGUIThread.CallGUIThread;
begin
    if Assigned(FOwner) then
        FOwner.OnThreadReceiveMessage(FOwner, FCurrentMessage);
end;

constructor TGUIThread.Create(AOwner: TWThread);
begin
    inherited Create(False);
    FMessageEvent := TEvent.Create(nil, False, False, '');
    FQueue := TList.Create;
    FSection := TCriticalSection.Create;
    FOwner := AOwner;
end;

destructor TGUIThread.Destroy;
begin
    FSection.Free;
    FQueue.Free;
    FMessageEvent.Free;
    inherited Destroy;
end;

{$IFDEF FPC}
procedure TGUIThread.PostMessage(Message: DWord; WParam: Word; LParam: NativeInt);
{$ELSE}
procedure TGUIThread.PostMessage(Message: Word; WParam: Word; LParam: NativeInt);
{$ENDIF}
var Msg: PThreadMessage;
begin
    GetMem(Msg, SizeOf(TThreadMessage));
    Msg^.Message := Message;
    Msg^.WParam := WParam;
    Msg^.LParam := LParam;
    FSection.Enter;
    FQueue.Add(Msg);
    FSection.Leave;
    FMessageEvent.SetEvent;
end;

procedure TGUIThread.StopThread;
begin
    Terminate;
    FMessageEvent.SetEvent;
end;

{ TWThread }

procedure TWThread.SetTimeOut(AValue: Cardinal);
begin
    if FTimeOut = AValue then Exit;
    FTimeOut := AValue;
    if not Suspended then
        FMessageEvent.SetEvent;
end;

procedure TWThread.DoTimeOut;
begin
    TGUIThread(FGUIThread).FTimeOut := true;
    TGUIThread(FGUIThread).FMessageEvent.SetEvent;
end;

procedure TWThread.Execute;
var Message: PThreadMessage;
    wr: TWaitResult;
begin
    while not Terminated do begin
        wr := FMessageEvent.WaitFor(FTimeOut);
        if not Terminated then
            case WR of
                wrSignaled: while FQueue.Count > 0 do begin
                    FSection.Enter;
                    Message := FQueue[0];
                    FQueue.Delete(0);
                    FSection.Leave;
                    Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        DoTimeOut;
                end;
            end;
    end;
end;

{$IFDEF FPC}
procedure TWThread.SendGUIMessage(Message: DWord; WParam: Word; LParam: NativeInt);
{$ELSE}
procedure TWThread.SendGUIMessage(Message: Word; WParam: Word; LParam: NativeInt);
{$ENDIF}
begin
    if Assigned(FGUIThread) then
        TGUIThread(FGUIThread).PostMessage(Message, WParam, LParam);
end;

constructor TWThread.Create;
begin
    Create(False);
end;

constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited Create(CreateSuspended);
    FQueue := TList.Create;
    FMessageEvent := TEvent.Create(nil, False, False, '');
    FSection := TCriticalSection.Create;
    FTimeOut := INFINITE;
    FTimeOutIsDirect := False;
    FGUIThread := TGUIThread.Create(Self);
end;

destructor TWThread.Destroy;
begin
    FGUIThread.Free;
    FMessageEvent.Free;
    FQueue.Free;
    FSection.Free;
    inherited Destroy;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
end;

{$IFDEF FPC}
procedure TWThread.PostMessage(Message: DWord; WParam: Word; LParam: NativeInt);
{$ELSE}
procedure TWThread.PostMessage(Message: Word; WParam: Word; LParam: NativeInt);
{$ENDIF}
var Msg: PThreadMessage;
begin
    GetMem(Msg, SizeOf(TThreadMessage));
    Msg^.Message := Message;
    Msg^.WParam := WParam;
    Msg^.LParam := LParam;
    FSection.Enter;
    FQueue.Add(Msg);
    FSection.Leave;
    FMessageEvent.SetEvent;
end;

procedure TWThread.StopThread;
begin
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.SetEvent;
end;

end.

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, wthread,
  Messages, ExtCtrls, StdCtrls;

const
  WM_STRING = WM_USER+$120;

type

  { TMyThread }

  TMyThread = class(TWThread)
  private
      procedure ReceiveString(var Msg: TThreadMessage); message WM_STRING;
  end;

  { TForm1 }

  TForm1 = class(TForm)
      Button1: TButton;
      Button2: TButton;
      Memo1: TMemo;
      procedure Button1Click(Sender: TObject);
      procedure Button2Click(Sender: TObject);
      procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
  private
      FThread: TMyThread;
      procedure StartThread;
      procedure StopThread;
  public
      procedure ReceiveMsg(Sender: TWThread; Msg: TThreadMessage);
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
begin
  if LongBool(FThread) then
      StopThread
  else
      StartThread;
end;

procedure TForm1.Button2Click(Sender: TObject);
var s: string;
begin
    s := '';
    if LongBool(FThread) and InputQuery('Input', 'Enter text', s) then begin
        // отправляем введенную строку в доп. поток
        Memo1.Lines.Add(Format('-> %s', [s]));
        FThread.PostMessage(WM_STRING, 0, NewString(s));
        s := '';
    end;
end;

procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
    if LongBool(FThread) then
        StopThread;
end;

procedure TForm1.ReceiveMsg(Sender: TWThread; Msg: TThreadMessage);
begin
    if Msg.Message = WM_STRING then
        Memo1.Lines.Add(Format('<- %s', [FreeString(Msg.LParam)]));
end;

procedure TForm1.StartThread;
begin
    if not LongBool(FThread) then begin
        FThread := TMyThread.Create(false);
        {$IFDEF FPC}
        FThread.OnThreadReceiveMessage := @ReceiveMsg;
        {$ELSE}
        FThread.OnThreadReceiveMessage := ReceiveMsg;
        {$ENDIF}
    end;
end;

procedure TForm1.StopThread;
begin
    if LongBool(FThread) then begin
        FThread.StopThread;
        FThread.Free;
        FThread := nil;
    end;
end;

{ TMyThread }

procedure TMyThread.ReceiveString(var Msg: TThreadMessage);
var s: string;
begin
   s := FreeString(Msg.LParam);
   SendGUIMessage(WM_STRING, 0, NewString(s));
   Sleep(5000);
   SendGUIMessage(WM_STRING, 0, NewString(s));
end;

end.

unit LazMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, WThread;

const
  WM_STRING = WM_USER+$120;

type
    { TMyThread }

    TMyThread = class(TWThread)
    private
        procedure ReceiveString(var Msg: TThreadMessage); message WM_STRING;
    end;

  TfrmThreadTest = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    FThread: TMyThread;
    procedure StartThread;
    procedure StopThread;
  public
    procedure ReceiveMsg(Sender: TWThread; Msg: TThreadMessage);
  end;

var
  frmThreadTest: TfrmThreadTest;

implementation

{$R *.dfm}

procedure TfrmThreadTest.Button1Click(Sender: TObject);
begin
  if LongBool(FThread) then
      StopThread
  else
      StartThread;
end;

procedure TfrmThreadTest.Button2Click(Sender: TObject);
var s: string;
begin
    s := '';
    if LongBool(FThread) and InputQuery('Input', 'Enter text', s) then begin
        // отправляем введенную строку в доп. поток
        Memo1.Lines.Add(Format('-> %s', [s]));
        FThread.PostMessage(WM_STRING, 0, NewString(s));
        s := '';
    end;
end;

procedure TfrmThreadTest.FormClose(Sender: TObject; var Action: TCloseAction);
begin
    if LongBool(FThread) then
        StopThread;
end;

procedure TfrmThreadTest.ReceiveMsg(Sender: TWThread; Msg: TThreadMessage);
begin
    if Msg.Message = WM_STRING then
        Memo1.Lines.Add(Format('<- %s', [FreeString(Msg.LParam)]));
end;

procedure TfrmThreadTest.StartThread;
begin
    if not LongBool(FThread) then begin
        FThread := TMyThread.Create(false);
        {$IFDEF FPC}
        FThread.OnThreadReceiveMessage := @ReceiveMsg;
        {$ELSE}
        FThread.OnThreadReceiveMessage := ReceiveMsg;
        {$ENDIF}
    end;
end;

procedure TfrmThreadTest.StopThread;
begin
    if LongBool(FThread) then begin
        FThread.StopThread;
        FThread.Free;
        FThread := nil;
    end;
end;

{ TMyThread }

procedure TMyThread.ReceiveString(var Msg: TThreadMessage);
var s: string;
begin
   s := FreeString(Msg.LParam);
   SendGUIMessage(WM_STRING, 0, NewString(s));
   Sleep(5000);
   SendGUIMessage(WM_STRING, 0, NewString(s));
end;

end.