unit WThread;

interface

uses
    Classes,
    Windows,
    Messages,
    SysUtils;

type
    TWThread = class;

    // событие на получение строки из потока
    TWThreadReceiveString = procedure(Sender: TWThread; const Text: string) of object;
    // событие на получение числа из потока
    TWThreadReceiveInt = procedure(Sender: TWThread; const Int: Integer) of object;
    // событие на получение строки и числа из потока
    TWThreadReceiveStringWord = procedure(Sender: TWThread; const Text: string; const Wrd: Word) of object;
    // событие на получение двух чисел из потока
    TWThreadReceiveIntWord = procedure(Sender: TWThread; const Int: Integer; const Wrd: Word) of object;

    TWThread = class(TThread)
    private
        FToolWindow: THandle;
        hCloseEvent: THandle;
        FOnThreadReceviceString: TWThreadReceiveString;
        FOnThreadReceiveInt: TWThreadReceiveInt;
        FOnThreadReceiveStringWord: TWThreadReceiveStringWord;
        FOnThreadReceiveIntWord: TWThreadReceiveIntWord;
    protected
        procedure WWindowProc(var Msg: TMessage);
        procedure SendString(const Text: string);
        procedure SendInteger(const Int: Integer);
        procedure SendStringWord(const Text: string; const Wrd: Word);
        procedure SendIntegerWord(const Int: Integer; const Wrd: Word);
        procedure DoThreadReceiveString(const Text: string);
        procedure Execute; override; // шаблон процедуры
    public
        constructor Create(CreateSuspended: Boolean); virtual;
        destructor Destroy; override;
        // отправка любого сообщения в поток
        function SendMessageToThread(AMsg: UInt; wParam: WPARAM; lParam: LPARAM): BOOL;
        // отправка строки в поток
        function SendStringToThread(const Text: string): boolean;
        // остановка потока по феншую
        function StopThread: boolean;
        // события на получение данных из потока
        property OnThreadReceviceString: TWThreadReceiveString read FOnThreadReceviceString write FOnThreadReceviceString;
        property OnThreadReceiveInt: TWThreadReceiveInt read FOnThreadReceiveInt write FOnThreadReceiveInt;
        property OnThreadReceiveStringWord: TWThreadReceiveStringWord read FOnThreadReceiveStringWord write FOnThreadReceiveStringWord;
        property OnThreadReceiveIntWord: TWThreadReceiveIntWord read FOnThreadReceiveIntWord write FOnThreadReceiveIntWord;
    end;

implementation

const
    WM_BASE             = WM_USER + $100;
    WM_STRING           = WM_BASE + 1;
    WM_INT              = WM_BASE + 2;
    WM_STRING_WORD      = WM_BASE + 3;
    WM_INT_WORD         = WM_BASE + 4;

    WM_MAX              = WM_INT_WORD;

{ TWThread }

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

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

procedure TWThread.DoThreadReceiveString(const Text: string);
begin
    if Assigned(FOnThreadReceviceString) then
        FOnThreadReceviceString(Self, Text);
end;

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

function TWThread.SendStringToThread(const Text: string): boolean;
var buf: LPARAM;
begin
    buf := 0;
    String(Buf) := Text;
    result := PostThreadMessage(ThreadID, WM_STRING, 0, buf);
end;

procedure TWThread.Execute;
var
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;
    str: string;
label
    EndOfThread;
begin
    // следующая строка должна быть всегда первой в процедуре, т.к. запускает очередь сообщений для потока
    PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
    HandlesToWaitFor[0] := hCloseEvent;
    // SleepEx не нужен, если подготовительный код до цикла while будет достаточно долго выполняться
    // уточняется опытным путем, иначе очередь сообщений потока не успеет запуститься и сообщения могут улететь в пустоту
    SleepEx(20, false);

    // тестовый пример vvv
    SendString('WThread started');
    // тестовый пример ^^^

    while not Terminated do begin
        if not PeekMessage(msg, 0, WM_BASE, WM_MAX, PM_REMOVE) then begin
            dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, INFINITE, QS_ALLINPUT);
            case dwHandleSignaled of
                WAIT_OBJECT_0: begin // выставлено событие остановки потока
                    Terminate;
                    goto EndOfThread;
                end;
                WAIT_OBJECT_0 + 1: begin // получено сообщение
                    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 // оконные сообщения тоже получаем
                Terminate;
                goto EndOfThread;
            end;
            WM_STRING: begin
                LPARAM(str) := msg.lParam;
                // что-нибудь делаем со строкой. например, отправляем обратно

                // тестовый пример vvv
                SendString(Format('received: %s', [str]));
                // тестовый пример ^^^

                str := ''; // "отпускаем" строку после работы с ней
            end;
            WM_INT: begin
                // здесь получаем число в msg.lparam;
            end;
        end;
    end;
EndOfThread:
    // все что создали в начале процедуры, здесь удаляем
end;

procedure TWThread.SendInteger(const Int: Integer);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_INT, 0, Int);
end;

procedure TWThread.SendIntegerWord(const Int: Integer; const Wrd: Word);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_INT_WORD, Wrd, Int);
end;

procedure TWThread.SendString(const Text: string);
var buf: LParam;
begin
    buf := 0;
    String(buf) := Text;
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_STRING, 0, buf);
end;

procedure TWThread.SendStringWord(const Text: string; const Wrd: Word);
var buf: LParam;
begin
    buf := 0;
    String(buf) := Text;
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_STRING, Wrd, buf);
end;

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

procedure TWThread.WWindowProc(var Msg: TMessage);
var str: String;
begin
    case Msg.Msg of
        WM_STRING: begin
            LPARAM(str) := Msg.LParam;
            DoThreadReceiveString(str);
            Msg.Result := 1;
        end;
        WM_INT: begin
            if Assigned(FOnThreadReceiveInt) then
                FOnThreadReceiveInt(Self, Msg.LParam);
            Msg.Result := 1;
        end;
        WM_STRING_WORD: begin
            LPARAM(str) := Msg.LParam;
            if Assigned(FOnThreadReceiveStringWord) then
                FOnThreadReceiveStringWord(Self, str, Msg.WParam);
            Msg.Result := 1;
        end;
        WM_INT_WORD: begin
            if Assigned(FOnThreadReceiveIntWord) then
                FOnThreadReceiveIntWord(Self, Msg.LParam, Msg.WParam);
            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;

type
  TfrmWThreadTest = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    FThread: TWThread;
    procedure ReceiveString(Sender: TWThread; const Text: string);
    procedure StartThread;
    procedure StopThread;
  public
  end;

var
  frmWThreadTest: TfrmWThreadTest;

implementation

{$R *.dfm}

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

procedure TfrmWThreadTest.Button2Click(Sender: TObject);
var s: string;
begin
    if Assigned(FThread) and InputQuery('Input', 'Enter text', s) then begin
        Memo1.Lines.Add(Format('-> %s', [s]));
        FThread.SendStringToThread(s);
    end;
end;

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

procedure TfrmWThreadTest.FormCreate(Sender: TObject);
begin
    Memo1.Lines.Clear;
end;

procedure TfrmWThreadTest.ReceiveString(Sender: TWThread; const Text: string);
begin
    Memo1.Lines.Add(Format('<- %s', [Text]));
end;

procedure TfrmWThreadTest.StartThread;
begin
    if not Assigned(FThread) then begin
        FThread := TWThread.Create(true);
        FThread.OnThreadReceviceString := ReceiveString;
        FThread.Start;
    end;
end;

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

end.

unit WThread;

interface

uses
    Classes,
    Windows,
    Messages,
    SysUtils;

type
    TWThread = class;

    // событие на получение строки из потока
    TWThreadReceiveString = procedure(Sender: TWThread; const Text: string) of object;
    // событие на получение числа из потока
    TWThreadReceiveInt = procedure(Sender: TWThread; const Int: Integer) of object;
    // событие на получение строки и числа из потока
    TWThreadReceiveStringWord = procedure(Sender: TWThread; const Text: string; const DWrd: Word) of object;
    // событие на получение двух чисел из потока
    TWThreadReceiveIntWord = procedure(Sender: TWThread; const Int: Integer; const DWrd: Word) of object;

    TWThread = class(TThread)
    private
        FToolWindow: THandle;
        hCloseEvent: THandle;
        FOnThreadReceviceString: TWThreadReceiveString;
        FOnThreadReceiveInt: TWThreadReceiveInt;
        FOnThreadReceiveStringWord: TWThreadReceiveStringWord;
        FOnThreadReceiveIntWord: TWThreadReceiveIntWord;
    protected
        procedure WWindowProc(var Msg: TMessage);
        procedure SendString(const Text: string);
        procedure SendInteger(const Int: Integer);
        procedure SendStringWord(const Text: string; const Wrd: DWord);
        procedure SendIntegerWord(const Int: Integer; const Wrd: DWord);
        procedure DoThreadReceiveString(const Text: string);
        procedure ParseUrl(const URL: string); // процедура парсера
        procedure Execute; override; // шаблон процедуры
    public
        constructor Create(CreateSuspended: Boolean); virtual;
        destructor Destroy; override;
        // отправка любого сообщения в поток
        function SendMessageToThread(AMsg: UInt; wParam: WPARAM; lParam: LPARAM): BOOL;
        // отправка строки в поток
        function SendStringToThread(const Text: string): boolean;
        // отправка числа и строки в поток
        function SendStringIntToThread(const Text: string; const Wrd: DWord): boolean;
        // остановка потока по феншую
        function StopThread: boolean;
        // события на получение данных из потока
        property OnThreadReceviceString: TWThreadReceiveString read FOnThreadReceviceString write FOnThreadReceviceString;
        property OnThreadReceiveInt: TWThreadReceiveInt read FOnThreadReceiveInt write FOnThreadReceiveInt;
        property OnThreadReceiveStringWord: TWThreadReceiveStringWord read FOnThreadReceiveStringWord write FOnThreadReceiveStringWord;
        property OnThreadReceiveIntWord: TWThreadReceiveIntWord read FOnThreadReceiveIntWord write FOnThreadReceiveIntWord;
    end;

implementation

const
    WM_BASE             = WM_USER + $100;
    WM_STRING           = WM_BASE + 1;
    WM_INT              = WM_BASE + 2;
    WM_STRING_WORD      = WM_BASE + 3;
    WM_INT_WORD         = WM_BASE + 4;

    WM_MAX              = WM_INT_WORD;

{ TWThread }

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

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

procedure TWThread.DoThreadReceiveString(const Text: string);
begin
    if Assigned(FOnThreadReceviceString) then
        FOnThreadReceviceString(Self, Text);
end;

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

function TWThread.SendStringToThread(const Text: string): boolean;
var buf: LPARAM;
begin
    buf := 0;
    String(Buf) := Text;
    result := PostThreadMessage(ThreadID, WM_STRING, 0, buf);
end;

function TWThread.SendStringIntToThread(const Text: string; const Wrd: DWord): boolean;
var buf: LPARAM;
begin
    buf := 0;
    String(Buf) := Text;
    result := PostThreadMessage(ThreadID, WM_STRING_WORD, Wrd, buf);
end;

procedure TWThread.Execute;
var
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;
    str: string;
    dw: DWord;
label
    EndOfThread;
begin
    // следующая строка должна быть всегда первой в процедуре, т.к. запускает очередь сообщений для потока
    PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
    HandlesToWaitFor[0] := hCloseEvent;
    // SleepEx не нужен, если подготовительный код до цикла while будет достаточно долго выполняться
    // уточняется опытным путем, иначе очередь сообщений потока не успеет запуститься и сообщения могут улететь в пустоту
    SleepEx(20, false);

    // тестовый пример vvv
    SendString('WThread started');
    // тестовый пример ^^^

    while not Terminated do begin
        if not PeekMessage(msg, 0, WM_BASE, WM_MAX, PM_REMOVE) then begin
            dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, INFINITE, QS_ALLINPUT);
            case dwHandleSignaled of
                WAIT_OBJECT_0: begin // выставлено событие остановки потока
                    Terminate;
                    goto EndOfThread;
                end;
                WAIT_OBJECT_0 + 1: begin // получено сообщение
                    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 // оконные сообщения тоже получаем
                Terminate;
                goto EndOfThread;
            end;
            WM_STRING: begin
                LPARAM(str) := msg.lParam;
                // что-нибудь делаем со строкой. например, отправляем обратно

                // тестовый пример vvv
                SendString(Format('received: %s', [str]));
                // тестовый пример ^^^

                str := ''; // "отпускаем" строку после работы с ней
            end;
            WM_INT: begin
                // здесь получаем число в msg.lparam;
            end;
            WM_STRING_WORD: begin
                dw := msg.wParam;
                LPARAM(str) := msg.lParam;
                // что-нибудь делаем со строкой и числом.
                // например число было 77
                case dw of
                    77: ParseUrl(str);
                end;

                str := ''; // "отпускаем" строку после работы с ней
            end;
        end;
    end;
EndOfThread:
    // все что создали в начале процедуры, здесь удаляем
end;

procedure TWThread.ParseUrl(const URL: string);
begin
    SendString('Begin parsing...');
    // парсер
    SendString('Done parsing...');
end;

procedure TWThread.SendInteger(const Int: Integer);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_INT, 0, Int);
end;

procedure TWThread.SendIntegerWord(const Int: Integer; const Wrd: DWord);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_INT_WORD, Wrd, Int);
end;

procedure TWThread.SendString(const Text: string);
var buf: LParam;
begin
    buf := 0;
    String(buf) := Text;
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_STRING, 0, buf);
end;

procedure TWThread.SendStringWord(const Text: string; const Wrd: DWord);
var buf: LParam;
begin
    buf := 0;
    String(buf) := Text;
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_STRING, Wrd, buf);
end;

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

procedure TWThread.WWindowProc(var Msg: TMessage);
var str: String;
begin
    case Msg.Msg of
        WM_STRING: begin
            LPARAM(str) := Msg.LParam;
            DoThreadReceiveString(str);
            Msg.Result := 1;
        end;
        WM_INT: begin
            if Assigned(FOnThreadReceiveInt) then
                FOnThreadReceiveInt(Self, Msg.LParam);
            Msg.Result := 1;
        end;
        WM_STRING_WORD: begin
            LPARAM(str) := Msg.LParam;
            if Assigned(FOnThreadReceiveStringWord) then
                FOnThreadReceiveStringWord(Self, str, Msg.WParam);
            Msg.Result := 1;
        end;
        WM_INT_WORD: begin
            if Assigned(FOnThreadReceiveIntWord) then
                FOnThreadReceiveIntWord(Self, Msg.LParam, Msg.WParam);
            Msg.Result := 1;
        end;
    else
        Msg.Result := DefWindowProc(FToolWindow, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;

end.