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

// 1 для работы необходимо изменить/дописать метод Execute
// 2 присвоить необходимые события OnReceiveXXX - это события будут вызываться в основном потоке в порядке очереди
// 3 protected процедуры SendXXX используются в Execute, т.е. внути доп. потока и вызывают соответствующие события
//   в совновном потоке. см.п.2
// 4 для сообщения информации доп.потоку из основного используются процедуры SendToThreadXXX

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: DWord) of object;
    // событие на получение двух чисел из потока
    TWThreadReceiveIntWord = procedure(Sender: TWThread; const Int: Integer; const DWrd: DWord) of object;
    // событие на получение сообщения из потока
    TWThreadReceiveMessage = procedure(Sender: TWThread; const Msg: Cardinal; const WParam: WPARAM; const LParam: LPARAM) of object;

    TWThread = class(TThread)
    private
        FToolWindow: THandle;
        hCloseEvent: THandle;
        FOnThreadReceiveString: TWThreadReceiveString;
        FOnThreadReceiveInt: TWThreadReceiveInt;
        FOnThreadReceiveStringWord: TWThreadReceiveStringWord;
        FOnThreadReceiveIntWord: TWThreadReceiveIntWord;
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
    protected
        function NewString(const Text: string): Pointer;
        function FreeString(var P: LPARAM): String;
        procedure WWindowProc(var Msg: TMessage);
        // 5 процедур отправки данных из Execute, с вызовом событий OnThreadReceiveXXX в основном потоке
        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 SendMyMessage(const Msg: TMessage);

        procedure DoThreadReceiveString(const Text: string);
        procedure DoThreadReceiveInt(const Int: Integer);
        procedure DoThreadReceiveStringWord(const Text: string; const DWrd: DWord);
        procedure DoThreadReceiveIntWord(const Int: Integer; const DWrd: DWord);
        procedure DoThreadReceiveMessage(const Msg: Cardinal; const WParam: WPARAM; const LParam: LPARAM);
        procedure Execute; override; // шаблон процедуры
    public
        constructor Create(CreateSuspended: Boolean); virtual;
        destructor Destroy; override;
        // отправка любого сообщения В поток
        function SendToThreadMessage(AMsg: UInt; wParam: WPARAM; lParam: LPARAM): BOOL;
        // отправка строки В поток
        function SendToThreadString(const Text: string): boolean;
        // отправка числа и строки В поток
        function SendToThreadStringWord(const Text: string; const Wrd: DWord): boolean;
        // отправка числа В поток
        function SendToThreadInt(const Int: Integer): boolean;
        // отправка двух чисел В поток
        function SendToThreadIntWord(const Int: Integer; const Wrd: DWord): boolean;
        // остановка потока по феншую
        function StopThread: boolean;
        // события на получение данных ИЗ потока, вызываются в основном потоке
        property OnThreadReceiveString: TWThreadReceiveString read FOnThreadReceiveString write FOnThreadReceiveString;
        property OnThreadReceiveInt: TWThreadReceiveInt read FOnThreadReceiveInt write FOnThreadReceiveInt;
        property OnThreadReceiveStringWord: TWThreadReceiveStringWord read FOnThreadReceiveStringWord write FOnThreadReceiveStringWord;
        property OnThreadReceiveIntWord: TWThreadReceiveIntWord read FOnThreadReceiveIntWord write FOnThreadReceiveIntWord;
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
    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_MSG              = WM_BASE + 5;

    WM_MAX              = WM_MSG;

    SizeOfChar          = SizeOf(Char);

{ 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.DoThreadReceiveInt(const Int: Integer);
begin
    if Assigned(FOnThreadReceiveInt) then
        FOnThreadReceiveInt(Self, Int);
end;

procedure TWThread.DoThreadReceiveIntWord(const Int: Integer; const DWrd: DWord);
begin
    if Assigned(FOnThreadReceiveIntWord) then
        FOnThreadReceiveIntWord(Self, Int, DWrd);
end;

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

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

procedure TWThread.DoThreadReceiveStringWord(const Text: string; const DWrd: DWord);
begin
    if Assigned(FOnThreadReceiveStringWord) then
        FOnThreadReceiveStringWord(Self, Text, DWrd);
end;

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

function TWThread.SendToThreadString(const Text: string): boolean;
var buf: Pointer;
begin
    buf := NewString(Text);
    result := PostThreadMessage(ThreadID, WM_STRING, 0, LPARAM(buf));
end;

function TWThread.SendToThreadStringWord(const Text: string; const Wrd: DWord): boolean;
var buf: Pointer;
begin
    buf := NewString(Text);
    result := PostThreadMessage(ThreadID, WM_STRING_WORD, Wrd, LPARAM(buf));
end;

function TWThread.SendToThreadInt(const Int: Integer): boolean;
begin
    result := PostThreadMessage(ThreadID, WM_INT, 0, Int);
end;

function TWThread.SendToThreadIntWord(const Int: Integer; const Wrd: DWord): boolean;
begin
    result := PostThreadMessage(ThreadID, WM_INT_WORD, Wrd, Int);
end;

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

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

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

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

    while not Terminated do begin
        if not PeekMessage(msg, 0, WM_BASE, WM_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
                    // событие "таймер", если MSWait = количество миллисекунд
                    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;
            // обработка сообщений из основного потока через SendToThreadXXX
            WM_INT: begin // SendToThreadInt
                // msg.lParam = Integer
            end;
            WM_STRING: begin //SendStringToThread
                str := FreeString(msg.lParam);
                SendString(str);
            end;
            WM_INT_WORD: begin // SendToThreadIntWord
                // msg.lparam = Integer
                // msg.wparam = dword
            end;
            WM_STRING_WORD: begin // SendToThreadStringWord
                // msg.wparam = dword
                str := FreeString(msg.lParam);
                SendString(str);
            end;
            // здесь можно добавить свои события, отправленные SendToThreadMessage из основного потока
        end;
    end;
EndOfThread:
    // все что создали в начале процедуры, здесь удаляем
end;

function TWThread.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 TWThread.NewString(const Text: string): Pointer;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > 0 then begin
        Result := Pointer(LocalAlloc(LPTR, l+SizeOfChar));
        if LongBool(Result) then
            Move(Pointer(Text)^, Result^, l);
    end else
        Result := nil;
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.SendMyMessage(const Msg: TMessage);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, Msg.Msg, Msg.WParam, Msg.LParam);
end;

procedure TWThread.SendString(const Text: string);
var buf: Pointer;
begin
    buf := NewString(Text);
    if LongBool(buf) and (FToolWindow <> 0) then
        PostMessage(FToolWindow, WM_STRING, 0, LPARAM(buf))
    else
        FreeString(LPARAM(buf));
end;

procedure TWThread.SendStringWord(const Text: string; const Wrd: DWord);
var buf: Pointer;
begin
    buf := NewString(Text);
    if LongBool(buf) and (FToolWindow <> 0) then
        PostMessage(FToolWindow, WM_STRING, Wrd, LPARAM(buf))
    else
        FreeString(LPARAM(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);
begin
    case Msg.Msg of
        WM_STRING: begin
            DoThreadReceiveString(FreeString(Msg.LParam));
            Msg.Result := 1;
        end;
        WM_INT: begin
            DoThreadReceiveInt(Msg.LParam);
            Msg.Result := 1;
        end;
        WM_STRING_WORD: begin
            DoThreadReceiveStringWord(FreeString(Msg.LParam), Msg.WParam);
            Msg.Result := 1;
        end;
        WM_INT_WORD: begin
            DoThreadReceiveIntWord(Msg.LParam, Msg.WParam);
            Msg.Result := 1;
        end;
        WM_MSG: 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.