unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, 2014, версия от 30.01.2014
//
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//  const WM_TEST_PROC = WM_THREAD_BASE + 1;
//  TMyThread = class(TWThread)
//     procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
//  данные процедуры будут выполняться в доп.потоке путем отправки связанного с ними сообщения в поток
//  см. PostToThreadMessage
// 2. Присвоить форме обработчика(ов) события OnThreadReceiveMessage, OnTimeOut - при необходимости
//
// Для обмена строками рекомендуется использовать функции NewString и FreeString
//
// Для корректной остановки потока и дальнейшей работы программы должна использоваться процедура StopThrad

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

{$IF DECLARED(FireMonkeyVersion)}
  {$DEFINE HAS_FMX}
{$ELSE}
  {$DEFINE HAS_VCL}
{$IFEND}

// для передачи строк между потоки используется выделенная память
{$DEFINE ALLOC_STRING}

interface

uses
    Classes,
    Messages,
    SysUtils
{$IFDEF FPC}
    ,Windows
    ,SyncObjs
{$ENDIF}
    ;

const
{$IFDEF FPC}
    INFINITE            = Cardinal($FFFFFFFF);
{$ENDIF}
    WM_USER             = $400;
    WM_THREAD_BASE      = WM_USER + $110;
    WM_THREAD_MAX       = WM_USER + $7FFF;

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

    TWThread = class;

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

    TWThread = class(TThread)
    private
{$IFDEF FPC}
        FQueue: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FTimeOut: Cardinal;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        procedure SetTimeOut(const Value: Cardinal);
    protected
{$IFNDEF FPC}
        FWindowHandle: THandle;
        procedure WWindowProc(var Msg: TMessage);
        procedure GetWindow;
        procedure FreeWindow;
{$ENDIF}
            // отправка сообщения из этого потока для вызова обработчика OnThreadReceiveMessage
        procedure PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoTimeout;
        procedure Execute; override;
        function GetTimeOut: Cardinal; virtual;
    public
        constructor Create; overload;
        constructor Create(CreateSuspended: Boolean); overload;
        destructor Destroy; override;
            // см TimeOutIsDirect, при true - перекрыть следующую процедуру
        procedure DirectTimeOut; virtual;
            // отправка любого сообщения В этот поток
        function PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): Boolean;
            // остановка потока по феншую
        procedure StopThread;
            // событие на получение данных ИЗ этого потока, вызывается в основном потоке
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
            // событие, возникающее при превышении интервала ожидания
        property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
            // интервал ожидания в мс, по-умолчанию - бесконечно
        property TimeOut: Cardinal read GetTimeOut write SetTimeOut;
            // 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

{$IFNDEF FPC}
uses Windows;
{$ENDIF}

const
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);


{$IFDEF ALLOC_STRING}
function FreeString(var P: NativeInt): 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): NativeInt;
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;
{$ELSE}
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    NativeInt(Result) := P;
end;
{$ENDIF}

{$IFDEF FPC}
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;
        procedure PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
        procedure StopThread;
    end;

{ TGUIThread }

procedure FreeQueue(const List: TList);
begin
    while List.Count > 0 do
        FreeMem(List[0]);
end;

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^;
                FreeMem(Message);
                if (FCurrentMessage.Message >= WM_THREAD_BASE)
                    and(FCurrentMessage.Message <= WM_THREAD_MAX) then
                    Synchronize(@CallGUIThread);
            end;
        end;
    end;
end;

procedure TGUIThread.CallGUIThread;
begin
    if Assigned(FOwner) then
        FOwner.DoThreadReceiveMessage(FCurrentMessage.Message, FCurrentMessage.WParam, FCurrentMessage.LParam);
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
    FreeQueue(FQueue);
    FSection.Free;
    FQueue.Free;
    FMessageEvent.Free;
    inherited Destroy;
end;

procedure TGUIThread.PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
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;
{$ENDIF}

{ TWThread }

constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited Create(CreateSuspended);
{$IFDEF FPC}
    FQueue := TList.Create;
    FMessageEvent := TEvent.Create(nil, False, False, '');
    FSection := TCriticalSection.Create;
    FGUIThread := TGUIThread.Create(Self);
{$ELSE}
    hCloseEvent := CreateEvent(nil, false, false, nil);
    GetWindow;
    FWindowHandle := 0;
{$ENDIF}
    FTimeOut := INFINITE;
    FTimeOutIsDirect := False;
end;

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

destructor TWThread.Destroy;
begin
{$IFDEF FPC}
    FMessageEvent.Free;
    FreeQueue(FQueue);
    FQueue.Free;
    FGUIThread.Free;
    FSection.Free;
{$ELSE}
    CloseHandle(hCloseEvent);
{$ENDIF}
    inherited;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
end;

procedure TWThread.DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
var ThreadMsg: TThreadMessage;
begin
    if Assigned(FOnThreadReceiveMessage) then begin
        ThreadMsg.Message := Msg;
        ThreadMsg.WParam := WParam;
        ThreadMsg.LParam := LParam;
        FOnThreadReceiveMessage(Self, ThreadMsg);
    end;
end;

procedure TWThread.DoTimeout;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).FTimeOut := true;
    TGUIThread(FGUIThread).FMessageEvent.SetEvent;
{$ELSE}
    if Assigned(FOnTimeOut) then
        FOnTimeOut(Self);
{$ENDIF}
end;

function TWThread.PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): boolean;
{$IFDEF FPC}
var PMsg: PThreadMessage;
begin
    GetMem(PMsg, SizeOf(TThreadMessage));
    PMsg^.Message := Msg;
    PMsg^.WParam := WParam;
    PMsg^.LParam := LParam;
    FSection.Enter;
    FQueue.Add(PMsg);
    FSection.Leave;
    FMessageEvent.SetEvent;
    result := true;
{$ELSE}
begin
    result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
{$ENDIF}
end;

procedure TWThread.SetTimeOut(const Value: Cardinal);
begin
{$IFDEF FPC}
    if FTimeOut <> Value then begin
        FTimeOut := Value;
        if not Suspended then
            FMessageEvent.SetEvent;
    end;
{$ELSE}
    if FTimeOut <> Value then begin
        FTimeOut := Value;
        if not Suspended then
            PostThreadMessage(ThreadID, WM_TIMEOUT, Value, 0);
    end;
{$ENDIF}
end;

procedure TWThread.Execute;
var
{$IFDEF FPC}
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        DoTimeOut;
                end;
            end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

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

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

    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLEVENTS);

            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
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        if LongBool(FWindowHandle) and (FWindowHandle = msg.hwnd) then begin
            // хэндл окна присвоен и пришло сообщение для окна
            TranslateMessage(msg);
            DispatchMessage(msg);
        end else case msg.message of
            WM_TIMEOUT: begin
                MSWait := msg.wParam;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
{$ENDIF}
end;

procedure TWThread.PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
begin
{$IFDEF FPC}
    if Assigned(FGUIThread) then
        TGUIThread(FGUIThread).PostMessage(Msg, WParam, LParam);
{$ELSE}
    if FToolWindow <> 0 then begin
        PostMessage(FToolWindow, Msg, WParam, LParam);
    end;
{$ENDIF}
end;

procedure TWThread.StopThread;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.SetEvent;
{$ELSE}
    FreeWindow;
    Terminate;
    SetEvent(hCloseEvent);
    //SleepEx(1, false);
    //result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
{$ENDIF}
end;

{$IFNDEF FPC}

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

function TWThread.GetTimeOut: Cardinal;
begin
    Result := FTimeOut;
end;

procedure TWThread.GetWindow;
begin
    FToolWindow := AllocateHWnd(WWindowProc);
end;

procedure TWThread.FreeWindow;
begin
    DeallocateHWnd(FToolWindow);
    FToolWindow := 0;
end;

{$ENDIF}

end.

// superlog (c) wadman, 2012-2014
// multithread safe logging

unit superlog;

{$B-} // complete boolean eval

interface

var SuperLogFileName: string;
    SuperLogEnabled: boolean;

function PostToLog(const Text: string): boolean;

implementation

uses SysUtils, Windows, Messages, DateUtils;

const WM_ADD_TO_LOG = WM_USER + $1001;

var
    LogWindowHandle: Cardinal;
    FirstLine: boolean;

const
    cUtilWindowExClass: TWndClass = (
        style: 0;
        lpfnWndProc: nil;
        cbClsExtra: 0;
        cbWndExtra: SizeOf(TMethod);
        hInstance: 0;
        hIcon: 0;
        hCursor: 0;
        hbrBackground: 0;
        lpszMenuName: nil;
        lpszClassName: 'TPUtilWindowLogEx');

    SizeOfChar          = SizeOf(Char);

function FreeString(var P: NativeInt): 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): NativeInt;
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;

function AddToLog(const DT: TDateTime; const Text: string): boolean;
var t: TextFile;
begin
    result := false;
    try
        AssignFile(t, SuperLogFileName);
        if (FileExists(SuperLogFileName)) then begin
            Append(t);
            if FirstLine then begin
                WriteLn(t, '');
            end;
        end else begin
            Rewrite(t);
        end;
        FirstLine := false;
        WriteLn(t, Format('%s : %s', [FormatDateTime('dd.mm.yyyy hh:nn:ss:zzz', Now), Text]));
        Flush(t);
        CloseFile(t);
        result := true;
    finally
        //Application.HandleException(Self);
    end;
end;

function StdWndProc(Window: THandle; Message, wp: WPARAM;
  lp: LPARAM): LRESULT; stdcall;
begin
    if Message = WM_ADD_TO_LOG then begin
        Result := Byte(AddToLog(UnixToDateTime(wp), FreeString(lp)));
    end else
        Result := DefWindowProc(Window, Message, wp, lp);
end;

procedure AllocateHWndEx;
var
    TempClass: TWndClass;
    UtilWindowExClass: TWndClass;
    ClassRegistered: Boolean;
begin
    UtilWindowExClass := cUtilWindowExClass;
    UtilWindowExClass.hInstance := HInstance;
    UtilWindowExClass.lpfnWndProc := @StdWndProc;

    ClassRegistered := Windows.GetClassInfo(HInstance, UtilWindowExClass.lpszClassName, TempClass);
    if not ClassRegistered or (TempClass.lpfnWndProc <> @StdWndProc) then begin
        if ClassRegistered then
            Windows.UnregisterClass(UtilWindowExClass.lpszClassName, HInstance);
        Windows.RegisterClass(UtilWindowExClass);
    end;
    LogWindowHandle := Windows.CreateWindowEx(Windows.WS_EX_TOOLWINDOW, UtilWindowExClass.lpszClassName,
        '', Windows.WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil);

    SetWindowLongPtr(LogWindowHandle, GWL_WNDPROC, LONG_PTR(@StdWndProc));
end;

procedure DeallocateHWndEx;
begin
    Windows.DestroyWindow(LogWindowHandle);
end;

function PostToLog(const Text: string): boolean;
begin
    result := SuperLogEnabled and LongBool(LogWindowHandle)
        and PostMessage(LogWindowHandle, WM_ADD_TO_LOG, DateTimeToUnix(Now), NewString(Text));
end;

function InitLogs: boolean;
begin
    SuperLogFileName := ChangeFileExt(ParamStr(0), '.log');
    AllocateHWndEx;
    result := LogWindowHandle <> 0;
end;

procedure DoneLogs;
begin
    if LogWindowHandle <> 0 then
        DeallocateHWndEx;
end;

initialization
    SuperLogEnabled := InitLogs;
    FirstLine := true;

finalization
    DoneLogs;

end.

unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, 2014, версия от 03.02.2014
//
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//  const WM_TEST_PROC = WM_THREAD_BASE + 1;
//  TMyThread = class(TWThread)
//     procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
//  данные процедуры будут выполняться в доп.потоке путем отправки связанного с ними сообщения в поток
//  см. PostToThreadMessage
// 2. Присвоить форме обработчика(ов) события OnThreadReceiveMessage, OnTimeOut - при необходимости
//
// Для обмена строками рекомендуется использовать функции NewString и FreeString
//
// Для корректной остановки потока и дальнейшей работы программы должна использоваться процедура StopThrad

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

{$IF DECLARED(FireMonkeyVersion)}
  {$DEFINE HAS_FMX}
{$ELSE}
  {$DEFINE HAS_VCL}
{$IFEND}

// для передачи строк между потоки используется выделенная память
{$DEFINE ALLOC_STRING}

interface

uses
    Classes,
    Messages,
    SysUtils
{$IFDEF FPC}
    ,Windows
    ,SyncObjs
{$ENDIF}
    ;

const
{$IFDEF FPC}
    INFINITE            = Cardinal($FFFFFFFF);
{$ENDIF}
    WM_USER             = $400;
    WM_THREAD_BASE      = WM_USER + $110;
    WM_THREAD_MAX       = WM_USER + $7FFF;

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

    TWThread = class;

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

    TWThread = class(TThread)
    private
{$IFDEF FPC}
        FQueue: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FTimeOut: Cardinal;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        procedure SetTimeOut(const Value: Cardinal);
    protected
{$IFNDEF FPC}
        FWindowHandle: THandle;
        procedure WWindowProc(var Msg: TMessage);
        procedure GetWindow;
        procedure FreeWindow;
{$ENDIF}
            // отправка сообщения из этого потока для вызова обработчика OnThreadReceiveMessage
        procedure PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoTimeout;
        procedure Execute; override;
        function GetTimeOut: Cardinal; virtual;
    public
        constructor Create; overload;
        constructor Create(CreateSuspended: Boolean); overload;
        destructor Destroy; override;
            // см TimeOutIsDirect, при true - перекрыть следующую процедуру
        procedure DirectTimeOut; virtual;
            // отправка любого сообщения В этот поток
        function PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): Boolean;
            // остановка потока по феншую
        procedure StopThread;
            // событие на получение данных ИЗ этого потока, вызывается в основном потоке
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
            // событие, возникающее при превышении интервала ожидания
        property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
            // интервал ожидания в мс, по-умолчанию - бесконечно
        property TimeOut: Cardinal read GetTimeOut write SetTimeOut;
            // 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

{$IFNDEF FPC}
uses Windows;
{$ENDIF}

const
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);


{$IFDEF ALLOC_STRING}
function FreeString(var P: NativeInt): 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): NativeInt;
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;
{$ELSE}
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    NativeInt(Result) := P;
end;
{$ENDIF}

{$IFDEF FPC}
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;
        procedure PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
        procedure StopThread;
    end;

{ TGUIThread }

procedure FreeQueue(const List: TList);
begin
    while List.Count > 0 do
        FreeMem(List[0]);
end;

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^;
                FreeMem(Message);
                if (FCurrentMessage.Message >= WM_THREAD_BASE)
                    and(FCurrentMessage.Message <= WM_THREAD_MAX) then
                    Synchronize(@CallGUIThread);
            end;
        end;
    end;
end;

procedure TGUIThread.CallGUIThread;
begin
    if Assigned(FOwner) then
        FOwner.DoThreadReceiveMessage(FCurrentMessage.Message, FCurrentMessage.WParam, FCurrentMessage.LParam);
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
    FreeQueue(FQueue);
    FSection.Free;
    FQueue.Free;
    FMessageEvent.Free;
    inherited Destroy;
end;

procedure TGUIThread.PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
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;
{$ENDIF}

{ TWThread }

constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited Create(CreateSuspended);
{$IFDEF FPC}
    FQueue := TList.Create;
    FMessageEvent := TEvent.Create(nil, False, False, '');
    FSection := TCriticalSection.Create;
    FGUIThread := TGUIThread.Create(Self);
{$ELSE}
    hCloseEvent := CreateEvent(nil, false, false, nil);
    GetWindow;
    FWindowHandle := 0;
{$ENDIF}
    FTimeOut := INFINITE;
    FTimeOutIsDirect := False;
end;

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

destructor TWThread.Destroy;
begin
{$IFDEF FPC}
    FMessageEvent.Free;
    FreeQueue(FQueue);
    FQueue.Free;
    FGUIThread.Free;
    FSection.Free;
{$ELSE}
    CloseHandle(hCloseEvent);
{$ENDIF}
    inherited;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
end;

procedure TWThread.DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
var ThreadMsg: TThreadMessage;
begin
    if Assigned(FOnThreadReceiveMessage) then begin
        ThreadMsg.Message := Msg;
        ThreadMsg.WParam := WParam;
        ThreadMsg.LParam := LParam;
        FOnThreadReceiveMessage(Self, ThreadMsg);
    end;
end;

procedure TWThread.DoTimeout;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).FTimeOut := true;
    TGUIThread(FGUIThread).FMessageEvent.SetEvent;
{$ELSE}
    if Assigned(FOnTimeOut) then
        FOnTimeOut(Self);
{$ENDIF}
end;

function TWThread.PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): boolean;
{$IFDEF FPC}
var PMsg: PThreadMessage;
begin
    GetMem(PMsg, SizeOf(TThreadMessage));
    PMsg^.Message := Msg;
    PMsg^.WParam := WParam;
    PMsg^.LParam := LParam;
    FSection.Enter;
    FQueue.Add(PMsg);
    FSection.Leave;
    FMessageEvent.SetEvent;
    result := true;
{$ELSE}
begin
    result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
{$ENDIF}
end;

procedure TWThread.SetTimeOut(const Value: Cardinal);
begin
{$IFDEF FPC}
    if FTimeOut <> Value then begin
        FTimeOut := Value;
        if not Suspended then
            FMessageEvent.SetEvent;
    end;
{$ELSE}
    if FTimeOut <> Value then begin
        FTimeOut := Value;
        if (not Suspended)and(GetCurrentThreadId <> ThreadID) then
            PostThreadMessage(ThreadID, WM_TIMEOUT, Value, 0);
    end;
{$ENDIF}
end;

procedure TWThread.Execute;
var
{$IFDEF FPC}
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                end;
            end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

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

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

    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLEVENTS);

            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
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        if LongBool(FWindowHandle) and (FWindowHandle = msg.hwnd) then begin
            // хэндл окна присвоен и пришло сообщение для окна
            TranslateMessage(msg);
            DispatchMessage(msg);
        end else case msg.message of
            WM_TIMEOUT: begin
                MSWait := msg.wParam;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
{$ENDIF}
end;

procedure TWThread.PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
begin
{$IFDEF FPC}
    if Assigned(FGUIThread) then
        TGUIThread(FGUIThread).PostMessage(Msg, WParam, LParam);
{$ELSE}
    if FToolWindow <> 0 then begin
        PostMessage(FToolWindow, Msg, WParam, LParam);
    end;
{$ENDIF}
end;

procedure TWThread.StopThread;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.SetEvent;
{$ELSE}
    FreeWindow;
    Terminate;
    SetEvent(hCloseEvent);
    //SleepEx(1, false);
    //result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
{$ENDIF}
end;

{$IFNDEF FPC}

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

function TWThread.GetTimeOut: Cardinal;
begin
    Result := FTimeOut;
end;

procedure TWThread.GetWindow;
begin
    FToolWindow := AllocateHWnd(WWindowProc);
end;

procedure TWThread.FreeWindow;
begin
    DeallocateHWnd(FToolWindow);
    FToolWindow := 0;
end;

{$ENDIF}

end.

// superlog (c) wadman, 2012-2014, 03.02.2014
// multithread safe logging

unit superlog;

{$B+} // complete boolean eval

interface

var SuperLogFileName: string;
    SuperLogEnabled: boolean;

function PostToLog(const Text: string): boolean;

implementation

uses SysUtils, Windows, Messages, DateUtils;

const WM_ADD_TO_LOG = WM_USER + $1001;

type
    PLogRecord = ^TLogRecord;
    TLogRecord = packed record
        DT: TDateTime;
        PString: NativeInt;
    end;

var
    LogWindowHandle: Cardinal;
    FirstLine: boolean;

const
    cUtilWindowExClass: TWndClass = (
        style: 0;
        lpfnWndProc: nil;
        cbClsExtra: 0;
        cbWndExtra: SizeOf(TMethod);
        hInstance: 0;
        hIcon: 0;
        hCursor: 0;
        hbrBackground: 0;
        lpszMenuName: nil;
        lpszClassName: 'TPUtilWindowLogEx');

    SizeOfChar          = SizeOf(Char);

function FreeString(var P: NativeInt): 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): NativeInt;
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;

function AddToLog(const DT: TDateTime; const Text: string): boolean;
var t: TextFile;
begin
    result := false;
    try
        AssignFile(t, SuperLogFileName);
        if (FileExists(SuperLogFileName)) then begin
            Append(t);
            if FirstLine then begin
                WriteLn(t, '');
            end;
        end else begin
            Rewrite(t);
        end;
        FirstLine := false;
        WriteLn(t, Format('%s : %s', [FormatDateTime('dd.mm.yyyy hh:nn:ss:zzz', DT), Text]));
        //Flush(t);
        CloseFile(t);
        result := true;
    finally
        //Application.HandleException(Self);
    end;
end;

function StdWndProc(Window: THandle; Message, wp: WPARAM;
  lp: LPARAM): LRESULT; stdcall;
var p: PLogRecord;
begin
    if Message = WM_ADD_TO_LOG then begin
        p := PLogRecord(lp);
        Result := Byte(AddToLog(p^.DT, FreeString(p^.PString)));
        FreeMem(p);
    end else
        Result := DefWindowProc(Window, Message, wp, lp);
end;

procedure AllocateHWndEx;
var
    TempClass: TWndClass;
    UtilWindowExClass: TWndClass;
    ClassRegistered: Boolean;
begin
    UtilWindowExClass := cUtilWindowExClass;
    UtilWindowExClass.hInstance := HInstance;
    UtilWindowExClass.lpfnWndProc := @StdWndProc;

    ClassRegistered := Windows.GetClassInfo(HInstance, UtilWindowExClass.lpszClassName, TempClass);
    if not ClassRegistered or (TempClass.lpfnWndProc <> @StdWndProc) then begin
        if ClassRegistered then
            Windows.UnregisterClass(UtilWindowExClass.lpszClassName, HInstance);
        Windows.RegisterClass(UtilWindowExClass);
    end;
    LogWindowHandle := Windows.CreateWindowEx(Windows.WS_EX_TOOLWINDOW, UtilWindowExClass.lpszClassName,
        '', Windows.WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil);

    SetWindowLongPtr(LogWindowHandle, GWL_WNDPROC, LONG_PTR(@StdWndProc));
end;

procedure DeallocateHWndEx;
begin
    Windows.DestroyWindow(LogWindowHandle);
end;

function PostToLog(const Text: string): boolean;
var p: PLogRecord;
    d: TDateTime;
begin
    result := SuperLogEnabled and LongBool(LogWindowHandle);
    if result then begin
        d := Now;
        p := AllocMem(SizeOf(TLogRecord));
        p^.DT := d;
        p^.PString := NewString(Text);
        result := PostMessage(LogWindowHandle, WM_ADD_TO_LOG, 0, NativeInt(p));
        if not result then
            FreeMem(p);
    end;
end;

function InitLogs: boolean;
begin
    SuperLogFileName := ChangeFileExt(ParamStr(0), '.log');
    AllocateHWndEx;
    result := LogWindowHandle <> 0;
end;

procedure DoneLogs;
begin
    if LogWindowHandle <> 0 then
        DeallocateHWndEx;
end;

initialization
    SuperLogEnabled := InitLogs;
    FirstLine := true;

finalization
    DoneLogs;

end.

unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, 2014, версия от 25.03.2014
//
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//  const WM_TEST_PROC = WM_THREAD_BASE + 1;
//  TMyThread = class(TWThread)
//     procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
//  данные процедуры будут выполняться в доп.потоке путем отправки связанного с ними сообщения в поток
//  см. PostToThreadMessage
// 2. Присвоить форме обработчика(ов) события OnThreadReceiveMessage, OnTimeOut - при необходимости
//
// Для обмена строками рекомендуется использовать функции NewString и FreeString
//
// Для корректной остановки потока и дальнейшей работы программы должна использоваться процедура StopThrad

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

{$IF DECLARED(FireMonkeyVersion)}
  {$DEFINE HAS_FMX}
{$ELSE}
  {$DEFINE HAS_VCL}
{$IFEND}

// для передачи строк между потоки используется выделенная память
{$DEFINE ALLOC_STRING}

interface

uses
    Classes,
    Messages,
    SysUtils
{$IFDEF FPC}
    ,Windows
    ,SyncObjs
{$ENDIF}
    ;

const
{$IFDEF FPC}
    INFINITE            = Cardinal($FFFFFFFF);
{$ENDIF}
    WM_USER             = $400;
    WM_THREAD_BASE      = WM_USER + $110;
    WM_THREAD_MAX       = WM_USER + $7FFF;

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

    TWThread = class;

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

    TWThread = class(TThread)
    private
{$IFDEF FPC}
        FQueue: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        procedure SetTimeOut(const Value: Cardinal);
    protected
        FTimeOut: Cardinal;
{$IFNDEF FPC}
        FWindowHandle: THandle;
        procedure WWindowProc(var Msg: TMessage);
        procedure GetWindow;
        procedure FreeWindow;
{$ENDIF}
            // отправка сообщения из этого потока для вызова обработчика OnThreadReceiveMessage
        procedure PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoTimeout;
        procedure Execute; override;
        function GetTimeOut: Cardinal; virtual;
    public
        constructor Create; overload;
        constructor Create(CreateSuspended: Boolean); overload;
        destructor Destroy; override;
            // см TimeOutIsDirect, при true - перекрыть следующую процедуру
        procedure DirectTimeOut; virtual;
            // отправка любого сообщения В этот поток
        function PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): Boolean;
            // остановка потока по феншую
        procedure StopThread;
            // событие на получение данных ИЗ этого потока, вызывается в основном потоке
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
            // событие, возникающее при превышении интервала ожидания
        property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
            // интервал ожидания в мс, по-умолчанию - бесконечно
        property TimeOut: Cardinal read GetTimeOut 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

{$IFNDEF FPC}
uses Windows;
{$ENDIF}

const
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);


{$IFDEF ALLOC_STRING}
function FreeString(var P: NativeInt): 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): NativeInt;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        if LongBool(Result) then
            Move(Pointer(Text)^, Pointer(Result)^, l);
    end else
        Result := 0;
end;
{$ELSE}
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    NativeInt(Result) := P;
end;
{$ENDIF}

{$IFDEF FPC}
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;
        procedure PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
        procedure StopThread;
    end;

{ TGUIThread }

procedure FreeQueue(const List: TList);
begin
    while List.Count > 0 do
        FreeMem(List[0]);
end;

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^;
                FreeMem(Message);
                if (FCurrentMessage.Message >= WM_THREAD_BASE)
                    and(FCurrentMessage.Message <= WM_THREAD_MAX) then
                    Synchronize(@CallGUIThread);
            end;
        end;
    end;
end;

procedure TGUIThread.CallGUIThread;
begin
    if Assigned(FOwner) then
        FOwner.DoThreadReceiveMessage(FCurrentMessage.Message, FCurrentMessage.WParam, FCurrentMessage.LParam);
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
    FreeQueue(FQueue);
    FSection.Free;
    FQueue.Free;
    FMessageEvent.Free;
    inherited Destroy;
end;

procedure TGUIThread.PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
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;
{$ENDIF}

{ TWThread }

constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited Create(CreateSuspended);
{$IFDEF FPC}
    FQueue := TList.Create;
    FMessageEvent := TEvent.Create(nil, False, False, '');
    FSection := TCriticalSection.Create;
    FGUIThread := TGUIThread.Create(Self);
{$ELSE}
    hCloseEvent := CreateEvent(nil, false, false, nil);
    GetWindow;
    FWindowHandle := 0;
{$ENDIF}
    FTimeOut := INFINITE;
    FTimeOutIsDirect := False;
end;

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

destructor TWThread.Destroy;
begin
{$IFDEF FPC}
    FMessageEvent.Free;
    FreeQueue(FQueue);
    FQueue.Free;
    FGUIThread.Free;
    FSection.Free;
{$ELSE}
    CloseHandle(hCloseEvent);
{$ENDIF}
    inherited;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
end;

procedure TWThread.DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
var ThreadMsg: TThreadMessage;
begin
    if Assigned(FOnThreadReceiveMessage) then begin
        ThreadMsg.Message := Msg;
        ThreadMsg.WParam := WParam;
        ThreadMsg.LParam := LParam;
        FOnThreadReceiveMessage(Self, ThreadMsg);
    end;
end;

procedure TWThread.DoTimeout;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).FTimeOut := true;
    TGUIThread(FGUIThread).FMessageEvent.SetEvent;
{$ELSE}
    if Assigned(FOnTimeOut) then
        FOnTimeOut(Self);
{$ENDIF}
end;

function TWThread.PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): boolean;
{$IFDEF FPC}
var PMsg: PThreadMessage;
begin
    GetMem(PMsg, SizeOf(TThreadMessage));
    PMsg^.Message := Msg;
    PMsg^.WParam := WParam;
    PMsg^.LParam := LParam;
    FSection.Enter;
    FQueue.Add(PMsg);
    FSection.Leave;
    FMessageEvent.SetEvent;
    result := true;
{$ELSE}
begin
    result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
{$ENDIF}
end;

procedure TWThread.SetTimeOut(const Value: Cardinal);
begin
{$IFDEF FPC}
    if FTimeOut <> Value then begin
        FTimeOut := Value;
        if not Suspended then
            FMessageEvent.SetEvent;
    end;
{$ELSE}
    if FTimeOut <> Value then begin
        FTimeOut := Value;
        if (not Suspended)and(GetCurrentThreadId <> ThreadID) then
            PostThreadMessage(ThreadID, WM_TIMEOUT, Value, 0);
    end;
{$ENDIF}
end;

procedure TWThread.Execute;
var
{$IFDEF FPC}
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                end;
            end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

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

    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLEVENTS);

            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
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        if LongBool(FWindowHandle) and (FWindowHandle = msg.hwnd) then begin
            // хэндл окна присвоен и пришло сообщение для окна
            TranslateMessage(msg);
            DispatchMessage(msg);
        end else case msg.message of
            WM_TIMEOUT: begin
                FTimeOut := msg.wParam;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
{$ENDIF}
end;

procedure TWThread.PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
begin
{$IFDEF FPC}
    if Assigned(FGUIThread) then
        TGUIThread(FGUIThread).PostMessage(Msg, WParam, LParam);
{$ELSE}
    if FToolWindow <> 0 then begin
        PostMessage(FToolWindow, Msg, WParam, LParam);
    end;
{$ENDIF}
end;

procedure TWThread.StopThread;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.SetEvent;
{$ELSE}
    FreeWindow;
    Terminate;
    SetEvent(hCloseEvent);
    //SleepEx(1, false);
    //result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
{$ENDIF}
end;

{$IFNDEF FPC}

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

function TWThread.GetTimeOut: Cardinal;
begin
    Result := FTimeOut;
end;

procedure TWThread.GetWindow;
begin
    FToolWindow := AllocateHWnd(WWindowProc);
end;

procedure TWThread.FreeWindow;
begin
    DeallocateHWnd(FToolWindow);
    FToolWindow := 0;
end;

{$ENDIF}

end.

// superlog (c) wadman, 2012-2014, 12.03.2014
// multithread safe logging

unit superlog;

{$B+} // complete boolean eval

interface

// log level
type
    TLogLevel = (SLL_MINIMUM, SLL_NORMAL, SLL_MAXIMUM, SLL_EXTRA);

var SuperLogFileName: string;
    SuperLogEnabled: boolean;
    SuperLogLevel: TLogLevel;

function PostToLog(const Text: string): boolean; overload; // with SLL_NORMAL
function PostToLog(const Text: string; const Level: TLogLevel): boolean; overload;

implementation

uses SysUtils, Windows, Messages, DateUtils;

const WM_ADD_TO_LOG = WM_USER + $1001;

type
    PLogRecord = ^TLogRecord;
    TLogRecord = packed record
        DT: TDateTime;
        PString: NativeInt;
    end;

var
    LogWindowHandle: Cardinal;
    FirstLine: boolean;

const
    cUtilWindowExClass: TWndClass = (
        style: 0;
        lpfnWndProc: nil;
        cbClsExtra: 0;
        cbWndExtra: SizeOf(TMethod);
        hInstance: 0;
        hIcon: 0;
        hCursor: 0;
        hbrBackground: 0;
        lpszMenuName: nil;
        lpszClassName: 'TPUtilWWindowLogEx');

    SizeOfChar          = SizeOf(Char);

function FreeString(var P: NativeInt): 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): NativeInt;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        if LongBool(Result) then
            Move(Pointer(Text)^, Pointer(Result)^, l);
    end else
        Result := 0;
end;

function AddToLog(const DT: TDateTime; const Text: string): boolean;
var t: TextFile;
begin
    result := false;
    try
        AssignFile(t, SuperLogFileName);
        if (FileExists(SuperLogFileName)) then begin
            Append(t);
            if FirstLine then begin
                WriteLn(t, '');
            end;
        end else begin
            Rewrite(t);
        end;
        FirstLine := false;
        WriteLn(t, Format('%s : %s', [FormatDateTime('dd.mm.yyyy hh:nn:ss:zzz', DT), Text]));
        CloseFile(t);
        result := true;
    finally
    end;
end;

function StdWndProc(Window: THandle; Message, wp: WPARAM;
  lp: LPARAM): LRESULT; stdcall;
var p: PLogRecord;
begin
    if Message = WM_ADD_TO_LOG then begin
        p := PLogRecord(lp);
        Result := Byte(AddToLog(p^.DT, FreeString(p^.PString)));
        FreeMem(p);
    end else
        Result := DefWindowProc(Window, Message, wp, lp);
end;

procedure AllocateHWndEx;
var
    TempClass: TWndClass;
    UtilWindowExClass: TWndClass;
    ClassRegistered: Boolean;
begin
    UtilWindowExClass := cUtilWindowExClass;
    UtilWindowExClass.hInstance := HInstance;
    UtilWindowExClass.lpfnWndProc := @StdWndProc;

    ClassRegistered := Windows.GetClassInfo(HInstance, UtilWindowExClass.lpszClassName, TempClass);
    if not ClassRegistered or (TempClass.lpfnWndProc <> @StdWndProc) then begin
        if ClassRegistered then
            Windows.UnregisterClass(UtilWindowExClass.lpszClassName, HInstance);
        Windows.RegisterClass(UtilWindowExClass);
    end;
    LogWindowHandle := Windows.CreateWindowEx(Windows.WS_EX_TOOLWINDOW, UtilWindowExClass.lpszClassName,
        '', Windows.WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil);

    SetWindowLongPtr(LogWindowHandle, GWL_WNDPROC, LONG_PTR(@StdWndProc));
end;

procedure DeallocateHWndEx;
begin
    Windows.DestroyWindow(LogWindowHandle);
end;

function PostToLog(const Text: string): boolean;
begin
    PostToLog(Text, SLL_NORMAL);
end;

function PostToLog(const Text: string; const Level: TLogLevel): boolean;
var p: PLogRecord;
    d: TDateTime;
begin
    if SmallInt(Level) <= SmallInt(SuperLogLevel) then begin
        result := SuperLogEnabled and LongBool(LogWindowHandle);
        if result then begin
            d := Now;
            p := AllocMem(SizeOf(TLogRecord));
            p^.DT := d;
            p^.PString := NewString(Text);
            result := PostMessage(LogWindowHandle, WM_ADD_TO_LOG, 0, NativeInt(p));
            if not result then begin
                LocalFree(HLOCAL(p^.PString));
                FreeMem(p);
            end;
        end;
    end else
        Result := true;
end;

function InitLogs: boolean;
begin
    SuperLogFileName := ChangeFileExt(ParamStr(0), '.log');
    AllocateHWndEx;
    result := LogWindowHandle <> 0;
end;

procedure DoneLogs;
begin
    if LogWindowHandle <> 0 then
        DeallocateHWndEx;
end;

initialization
    SuperLogLevel := SLL_NORMAL;
    SuperLogEnabled := InitLogs;
    FirstLine := true;

finalization
    DoneLogs;

end.

unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, 2014, версия от 30.04.2014
//
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//  const WM_TEST_PROC = WM_THREAD_BASE + 1;
//  TMyThread = class(TWThread)
//     procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
//  данные процедуры будут выполняться в доп.потоке путем отправки связанного с ними сообщения в поток
//  см. PostToThreadMessage
// 2. Присвоить форме обработчика(ов) события OnThreadReceiveMessage, OnTimeOut - при необходимости
//
// Для обмена строками рекомендуется использовать функции NewString и FreeString
//
// Для корректной остановки потока и дальнейшей работы программы должна использоваться процедура StopThrad

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

{$IF DECLARED(FireMonkeyVersion)}
  {$DEFINE HAS_FMX}
{$ELSE}
  {$DEFINE HAS_VCL}
{$IFEND}

// для передачи строк между потоки используется выделенная память
{$DEFINE ALLOC_STRING}

interface

uses
    Classes,
    Messages,
    SysUtils
{$IFDEF FPC}
    ,Windows
    ,SyncObjs
{$ENDIF}
    ;

const
{$IFDEF FPC}
    INFINITE            = Cardinal($FFFFFFFF);
{$ENDIF}
    WM_USER             = $400;
    WM_THREAD_BASE      = WM_USER + $110;
    WM_THREAD_MAX       = WM_USER + $7FFF;

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

    TWThread = class;

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

    TWThread = class(TThread)
    private
{$IFDEF FPC}
        FQueue: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        procedure SetTimeOut(const Value: Cardinal);
    protected
        FTimeOut: Cardinal;
{$IFNDEF FPC}
        FWindowHandle: THandle;
        procedure WWindowProc(var Msg: TMessage);
        procedure GetWindow;
        procedure FreeWindow;
{$ENDIF}
            // отправка сообщения из этого потока для вызова обработчика OnThreadReceiveMessage
        procedure PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoTimeout;
        procedure Execute; override;
        function GetTimeOut: Cardinal; virtual;
    public
        constructor Create; overload;
        constructor Create(CreateSuspended: Boolean); overload;
        destructor Destroy; override;
        procedure InitThread; virtual;
        procedure DoneThread; virtual;
            // см TimeOutIsDirect, при true - перекрыть следующую процедуру
        procedure DirectTimeOut; virtual;
            // отправка любого сообщения В этот поток
        function PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): Boolean;
            // остановка потока по феншую
        procedure StopThread;
            // событие на получение данных ИЗ этого потока, вызывается в основном потоке
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
            // событие, возникающее при превышении интервала ожидания
        property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
            // интервал ожидания в мс, по-умолчанию - бесконечно
        property TimeOut: Cardinal read GetTimeOut 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

{$IFNDEF FPC}
uses Windows;
{$ENDIF}

const
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);


{$IFDEF ALLOC_STRING}
function FreeString(var P: NativeInt): 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): NativeInt;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        if LongBool(Result) then
            Move(Pointer(Text)^, Pointer(Result)^, l);
    end else
        Result := 0;
end;
{$ELSE}
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    NativeInt(Result) := P;
end;
{$ENDIF}

{$IFDEF FPC}
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;
        procedure PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
        procedure StopThread;
    end;

{ TGUIThread }

procedure FreeQueue(const List: TList);
begin
    while List.Count > 0 do
        FreeMem(List[0]);
end;

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^;
                FreeMem(Message);
                if (FCurrentMessage.Message >= WM_THREAD_BASE)
                    and(FCurrentMessage.Message <= WM_THREAD_MAX) then
                    Synchronize(@CallGUIThread);
            end;
        end;
    end;
end;

procedure TGUIThread.CallGUIThread;
begin
    if Assigned(FOwner) then
        FOwner.DoThreadReceiveMessage(FCurrentMessage.Message, FCurrentMessage.WParam, FCurrentMessage.LParam);
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
    FreeQueue(FQueue);
    FSection.Free;
    FQueue.Free;
    FMessageEvent.Free;
    inherited Destroy;
end;

procedure TGUIThread.PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
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;
{$ENDIF}

{ TWThread }

constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited Create(CreateSuspended);
{$IFDEF FPC}
    FQueue := TList.Create;
    FMessageEvent := TEvent.Create(nil, False, False, '');
    FSection := TCriticalSection.Create;
    FGUIThread := TGUIThread.Create(Self);
{$ELSE}
    hCloseEvent := CreateEvent(nil, false, false, nil);
    GetWindow;
    FWindowHandle := 0;
{$ENDIF}
    FTimeOut := INFINITE;
    FTimeOutIsDirect := False;
end;

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

destructor TWThread.Destroy;
begin
{$IFDEF FPC}
    FMessageEvent.Free;
    FreeQueue(FQueue);
    FQueue.Free;
    FGUIThread.Free;
    FSection.Free;
{$ELSE}
    CloseHandle(hCloseEvent);
{$ENDIF}
    inherited;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
end;

procedure TWThread.DoneThread;
begin
    // empty
end;

procedure TWThread.DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
var ThreadMsg: TThreadMessage;
begin
    if Assigned(FOnThreadReceiveMessage) then begin
        ThreadMsg.Message := Msg;
        ThreadMsg.WParam := WParam;
        ThreadMsg.LParam := LParam;
        FOnThreadReceiveMessage(Self, ThreadMsg);
    end;
end;

procedure TWThread.DoTimeout;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).FTimeOut := true;
    TGUIThread(FGUIThread).FMessageEvent.SetEvent;
{$ELSE}
    if Assigned(FOnTimeOut) then
        FOnTimeOut(Self);
{$ENDIF}
end;

function TWThread.PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): boolean;
{$IFDEF FPC}
var PMsg: PThreadMessage;
begin
    GetMem(PMsg, SizeOf(TThreadMessage));
    PMsg^.Message := Msg;
    PMsg^.WParam := WParam;
    PMsg^.LParam := LParam;
    FSection.Enter;
    FQueue.Add(PMsg);
    FSection.Leave;
    FMessageEvent.SetEvent;
    result := true;
{$ELSE}
begin
    result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
{$ENDIF}
end;

procedure TWThread.SetTimeOut(const Value: Cardinal);
begin
{$IFDEF FPC}
    if FTimeOut <> Value then begin
        FTimeOut := Value;
        if not Suspended then
            FMessageEvent.SetEvent;
    end;
{$ELSE}
    if FTimeOut <> Value then begin
        FTimeOut := Value;
        if (not Suspended)and(GetCurrentThreadId <> ThreadID) then
            PostThreadMessage(ThreadID, WM_TIMEOUT, Value, 0);
    end;
{$ENDIF}
end;

procedure TWThread.Execute;
var
{$IFDEF FPC}
    Message: PThreadMessage;
    wr: TWaitResult;
begin
    InitThread;
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                end;
            end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

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

    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLEVENTS);

            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
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        if LongBool(FWindowHandle) and (FWindowHandle = msg.hwnd) then begin
            // хэндл окна присвоен и пришло сообщение для окна
            TranslateMessage(msg);
            DispatchMessage(msg);
        end else case msg.message of
            WM_TIMEOUT: begin
                FTimeOut := msg.wParam;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
{$ENDIF}
    DoneThread;
end;

procedure TWThread.PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
begin
{$IFDEF FPC}
    if Assigned(FGUIThread) then
        TGUIThread(FGUIThread).PostMessage(Msg, WParam, LParam);
{$ELSE}
    if FToolWindow <> 0 then begin
        PostMessage(FToolWindow, Msg, WParam, LParam);
    end;
{$ENDIF}
end;

procedure TWThread.StopThread;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.SetEvent;
{$ELSE}
    FreeWindow;
    Terminate;
    SetEvent(hCloseEvent);
    //SleepEx(1, false);
    //result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
{$ENDIF}
end;

{$IFNDEF FPC}

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

function TWThread.GetTimeOut: Cardinal;
begin
    Result := FTimeOut;
end;

procedure TWThread.GetWindow;
begin
    FToolWindow := AllocateHWnd(WWindowProc);
end;

procedure TWThread.InitThread;
begin
    // empty
end;

procedure TWThread.FreeWindow;
begin
    DeallocateHWnd(FToolWindow);
    FToolWindow := 0;
end;

{$ENDIF}

end.

unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, 2014, версия от 28.07.2014
//
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//  const WM_TEST_PROC = WM_THREAD_BASE + 1;
//  TMyThread = class(TWThread)
//     procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
//  данные процедуры будут выполняться в доп.потоке путем отправки связанного с ними сообщения в поток
//  см. PostToThreadMessage
// 2. Присвоить форме обработчика(ов) события OnThreadReceiveMessage (OnTimeOut - при необходимости)
//
// Для обмена строками рекомендуется использовать функции NewString и FreeString
//
// Для корректной остановки потока и дальнейшей работы программы должна использоваться процедура StopThrad

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

{$IF DECLARED(FireMonkeyVersion)}
  {$DEFINE HAS_FMX}
{$ELSE}
  {$DEFINE HAS_VCL}
{$IFEND}

// для передачи строк между потоками используется выделенная память
{$DEFINE ALLOC_STRING}

interface

uses
    Classes,
    Messages,
    SysUtils
{$IFDEF FPC}
    ,Windows
    ,SyncObjs
{$ENDIF}
    ;

const
{$IFDEF FPC}
    INFINITE            = Cardinal($FFFFFFFF);
{$ENDIF}
    WM_USER             = $400;
    WM_THREAD_BASE      = WM_USER + $110;
    WM_THREAD_MAX       = WM_USER + $300;

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

    TWThread = class;

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

    TWThread = class(TThread)
    private
{$IFDEF FPC}
        FQueue: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        procedure SetTimeOut(const Value: Cardinal);
    protected
        FTimeOut: Cardinal;
{$IFNDEF FPC}
        FWindowHandle: THandle;
        procedure WWindowProc(var Msg: TMessage);
        procedure GetWindow;
        procedure FreeWindow;
{$ENDIF}
            // отправка сообщения из этого потока для вызова обработчика OnThreadReceiveMessage
        procedure PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoTimeout;
        procedure Execute; override;
        function GetTimeOut: Cardinal; virtual;
    public
        constructor Create; overload;
        constructor Create(CreateSuspended: Boolean); overload;
        destructor Destroy; override;
        procedure InitThread; virtual;
        procedure DoneThread; virtual;
            // см TimeOutIsDirect, при true - перекрыть следующую процедуру
        procedure DirectTimeOut; virtual;
            // отправка любого сообщения В этот поток
        function PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): Boolean;
            // остановка потока по феншую
        procedure StopThread;
            // событие на получение данных ИЗ этого потока, вызывается в основном потоке
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
            // событие, возникающее при превышении интервала ожидания
        property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
            // интервал ожидания в мс, по-умолчанию - бесконечно
        property TimeOut: Cardinal read GetTimeOut 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

{$IFNDEF FPC}
uses Windows;
{$ENDIF}

const
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);


{$IFDEF ALLOC_STRING}
// для передачи строки между программами
function GlobalNewString(const Text: string): NativeInt;
var l: Integer;
    p: pointer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        Result := GlobalAlloc(GHND, l+SizeOfChar);
        if LongBool(Result) then begin
            p := GlobalLock(Result);
            Move(Pointer(Text)^, Pointer(p)^, l);
            GlobalUnlock(Result);
        end
    end else
        Result := 0;
end;

// для передачи строки между программами
function GlobalFreeString(var P: NativeInt): String;
var ps: pointer;
begin
    if LongBool(P) then begin
        ps := GlobalLock(P);
        SetLength(Result, Length(PChar(ps)));
        Move(Pointer(ps)^, Pointer(Result)^, Length(Result)*SizeOfChar);
        GlobalUnlock(P);
        P := GlobalFree(P);
    end;
end;

// для передачи строки в пределах одной программы
function FreeString(var P: NativeInt): 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): NativeInt;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        if LongBool(Result) then
            Move(Pointer(Text)^, Pointer(Result)^, l);
    end else
        Result := 0;
end;
{$ELSE}
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    NativeInt(Result) := P;
end;
{$ENDIF}

{$IFDEF FPC}
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;
        procedure PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
        procedure StopThread;
    end;

{ TGUIThread }

procedure FreeQueue(const List: TList);
begin
    while List.Count > 0 do
        FreeMem(List[0]);
end;

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^;
                FreeMem(Message);
                if (FCurrentMessage.Message >= WM_THREAD_BASE)
                    and(FCurrentMessage.Message <= WM_THREAD_MAX) then
                    Synchronize(@CallGUIThread);
            end;
        end;
    end;
end;

procedure TGUIThread.CallGUIThread;
begin
    if Assigned(FOwner) then
        FOwner.DoThreadReceiveMessage(FCurrentMessage.Message, FCurrentMessage.WParam, FCurrentMessage.LParam);
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
    FreeQueue(FQueue);
    FSection.Free;
    FQueue.Free;
    FMessageEvent.Free;
    inherited Destroy;
end;

procedure TGUIThread.PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
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;
{$ENDIF}

{ TWThread }

constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited Create(CreateSuspended);
{$IFDEF FPC}
    FQueue := TList.Create;
    FMessageEvent := TEvent.Create(nil, False, False, '');
    FSection := TCriticalSection.Create;
    FGUIThread := TGUIThread.Create(Self);
{$ELSE}
    hCloseEvent := CreateEvent(nil, false, false, nil);
    GetWindow;
    FWindowHandle := 0;
{$ENDIF}
    FTimeOut := INFINITE;
    FTimeOutIsDirect := False;
end;

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

destructor TWThread.Destroy;
begin
{$IFDEF FPC}
    FMessageEvent.Free;
    FreeQueue(FQueue);
    FQueue.Free;
    FGUIThread.Free;
    FSection.Free;
{$ELSE}
    CloseHandle(hCloseEvent);
{$ENDIF}
    inherited;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
end;

procedure TWThread.DoneThread;
begin
    // empty
end;

procedure TWThread.DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
var ThreadMsg: TThreadMessage;
begin
    if Assigned(FOnThreadReceiveMessage) then begin
        ThreadMsg.Message := Msg;
        ThreadMsg.WParam := WParam;
        ThreadMsg.LParam := LParam;
        FOnThreadReceiveMessage(Self, ThreadMsg);
    end;
end;

procedure TWThread.DoTimeout;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).FTimeOut := true;
    TGUIThread(FGUIThread).FMessageEvent.SetEvent;
{$ELSE}
    if Assigned(FOnTimeOut) then
        FOnTimeOut(Self);
{$ENDIF}
end;

function TWThread.PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): boolean;
{$IFDEF FPC}
var PMsg: PThreadMessage;
begin
    GetMem(PMsg, SizeOf(TThreadMessage));
    PMsg^.Message := Msg;
    PMsg^.WParam := WParam;
    PMsg^.LParam := LParam;
    FSection.Enter;
    FQueue.Add(PMsg);
    FSection.Leave;
    FMessageEvent.SetEvent;
    result := true;
{$ELSE}
begin
    result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
{$ENDIF}
end;

procedure TWThread.SetTimeOut(const Value: Cardinal);
begin
{$IFDEF FPC}
    if FTimeOut <> Value then begin
        FTimeOut := Value;
        if not Suspended then
            FMessageEvent.SetEvent;
    end;
{$ELSE}
    if FTimeOut <> Value then begin
        FTimeOut := Value;
        if (not Suspended)and(GetCurrentThreadId <> ThreadID) then
            PostThreadMessage(ThreadID, WM_TIMEOUT, Value, 0);
    end;
{$ENDIF}
end;

procedure TWThread.Execute;
var
{$IFDEF FPC}
    Message: PThreadMessage;
    wr: TWaitResult;
begin
    InitThread;
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                end;
            end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

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

    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLEVENTS);

            case dwHandleSignaled of
                WAIT_OBJECT_0: begin // выставлено событие остановки потока
                    if not FreeOnTerminate then
                        Terminate;
                    break;
                end;
                WAIT_OBJECT_0 + 1: begin // получено сообщение
                    Continue;
                end;
                WAIT_TIMEOUT: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;

        if Terminated then break;

        if LongBool(FWindowHandle) and (FWindowHandle = msg.hwnd) then begin
            // хэндл окна присвоен и пришло сообщение для окна
            TranslateMessage(msg);
            DispatchMessage(msg);
        end else case msg.message of
            WM_TIMEOUT: begin
                FTimeOut := msg.wParam;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                // ищем и вызываем procedure of object message
                Dispatch(message);
            end;
        end;
    end;
{$ENDIF}
    DoneThread;
end;

procedure TWThread.PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
begin
{$IFDEF FPC}
    if Assigned(FGUIThread) then
        TGUIThread(FGUIThread).PostMessage(Msg, WParam, LParam);
{$ELSE}
    if FToolWindow <> 0 then begin
        PostMessage(FToolWindow, Msg, WParam, LParam);
    end;
{$ENDIF}
end;

procedure TWThread.StopThread;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.SetEvent;
{$ELSE}
    FreeWindow;
    Terminate;
    SetEvent(hCloseEvent);
    //SleepEx(1, false);
    //result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
{$ENDIF}
end;

{$IFNDEF FPC}

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

function TWThread.GetTimeOut: Cardinal;
begin
    Result := FTimeOut;
end;

procedure TWThread.GetWindow;
begin
    FToolWindow := AllocateHWnd(WWindowProc);
end;

procedure TWThread.InitThread;
begin
    // empty
end;

procedure TWThread.FreeWindow;
begin
    DeallocateHWnd(FToolWindow);
    FToolWindow := 0;
end;

{$ENDIF}

end.

unit DirMonitorMain;

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_FILE_FOUND       = WM_THREAD_BASE + 1;
    WM_PROCESS_FILE     = WM_THREAD_BASE + 2;
    WM_PROCESSED_FILE   = WM_THREAD_BASE + 3;

type
    TDirMonitorThread = class(TWthread)
    private
        FDir: string;
    public
        constructor Create(const ADir: string);
        procedure DirectTimeOut; override;
        property Dir: string read FDir;
    end;

    TImportThread = class(TWThread)
    public
        procedure WMProcessFile(var Msg: TThreadMessage); message WM_PROCESS_FILE;
    end;

  TfrmDirMonitorMain = class(TForm)
        Memo1: TMemo;
        procedure FormCreate(Sender: TObject);
        procedure FormDestroy(Sender: TObject);
  private
        FDirMonitorThread: TDirMonitorThread;
        FImportThread: TImportThread;
  public
        procedure OnReceiveFromThread(Sender: TWThread; var Msg: TThreadMessage);
        procedure ToLog(const Text: string);
  end;

var
  frmDirMonitorMain: TfrmDirMonitorMain;

implementation

{$R *.dfm}

{ TDirMonitorThread }

constructor TDirMonitorThread.Create(const ADir: string);
begin
    inherited Create;
    // папка
    FDir := ADir;
    // приоритет
    Priority := tpLower;
    // процедура DirectTimeOut по таймауту будет выполнятся в контексте этого потока
    TimeOutIsDirect := true;
    // раз в минуту
    FTimeOut := 60000;
end;

// выполняется в доп. потоке
procedure TDirMonitorThread.DirectTimeOut;
begin
    // симулируем ситуацию, когда файл наден и скопирован и передаем путь и имя файла в основной поток
    // NewString и FreeString важны для передачи строк между потоками
    PostMessageFromThread(WM_FILE_FOUND, 0, NewString(IncludeTrailingBackslash(Dir)+Format('File%d.dbf', [Random(100)])));
    // и дальше уходим спать на минуту
end;

{ TImportThread }
// выполняется в доп. потоке
procedure TImportThread.WMProcessFile(var Msg: TThreadMessage);
var FileName: string;
begin
    // симулируем обработку файла
    FileName := FreeString(Msg.LParam);
    // будем 5 секунд импортировать
    SleepEx(5000, true);
    // сообщим об окончании обработки
    PostMessageFromThread(WM_PROCESSED_FILE, 0, NewString(FileName));
end;

{ TfrmDirMonitorMain }

// процедура, которая обрабатывает в основном потоке сообщения от доп. потоков
procedure TfrmDirMonitorMain.FormCreate(Sender: TObject);
var i: int64;
    ii: integer;
    ai: array[0..3] of byte;
begin
    Randomize;
    Memo1.Lines.Clear;
    // Запускаем доп. потоки
    FDirMonitorThread := TDirMonitorThread.Create('D:\SomeDir');    // 2060
    FDirMonitorThread.OnThreadReceiveMessage := OnReceiveFromThread;
    FImportThread := TImportThread.Create;
    FImportThread.OnThreadReceiveMessage := OnReceiveFromThread;
end;

procedure TfrmDirMonitorMain.FormDestroy(Sender: TObject);
begin
    FDirMonitorThread.StopThread;
    FImportThread.StopThread;
end;

// обработчик сообщений от доп потоков
procedure TfrmDirMonitorMain.OnReceiveFromThread(Sender: TWThread; var Msg: TThreadMessage);
var FileName: string;
begin
    case Msg.Message of
        WM_FILE_FOUND: begin
            // новый файл найден см. TDirMonitorThread.DirectTimeOut;
            // NewString и FreeString важны для передачи строк между потоками
            FileName := FreeString(Msg.LParam);
            ToLog(Format('Found: %s', [FileName]));
            // сообщим импортирующему потоку имя этого файла
            FImportThread.PostToThreadMessage(WM_PROCESS_FILE, 0, NewString(FileName));
        end;
        WM_PROCESSED_FILE: begin
            // импортирующий поток сообщил о том, что обработка закончена
            FileName := FreeString(Msg.LParam);
            ToLog(Format('Imported: %s', [FileName]));
        end;
    end;
end;

procedure TfrmDirMonitorMain.ToLog(const Text: string);
begin
    Memo1.Lines.Add(Format('%s : %s', [FOrmatDateTime('hh:nn:ss:zzz', Now), Text]));
end;

end.

unit mainThreadWnd;

interface

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

const
    WM_SHOW1    = WM_THREAD_BASE + 1;
    WM_HIDE1    = WM_THREAD_BASE + 2;

type
    TWindowThread = class(TWThread)
        procedure WMShow1(var Msg: TThreadMessage); message WM_SHOW1;
        procedure WMHide1(var Msg: TThreadMessage); message WM_HIDE1;
    end;

  TfrmThreadWnd = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    FThread: TWindowThread;
  public
  end;

var
  frmThreadWnd: TfrmThreadWnd;

implementation

{$R *.dfm}

procedure TfrmThreadWnd.Button1Click(Sender: TObject);
begin
    FThread.PostToThreadMessage(WM_SHOW1, 0, 0);
end;

procedure TfrmThreadWnd.Button2Click(Sender: TObject);
var i: integer;
begin
    for i := 0 to 10 do
        Sleep(100);
end;

procedure TfrmThreadWnd.Button3Click(Sender: TObject);
begin
    FThread.PostToThreadMessage(WM_HIDE1, 0, 0);
end;

procedure TfrmThreadWnd.FormCreate(Sender: TObject);
begin
    FThread := TWindowThread.Create;
end;

procedure TfrmThreadWnd.FormDestroy(Sender: TObject);
begin
    FThread.StopThread;
    FThread.Free;
end;

{ TWindowThread }

var
    LabelText, LabelTime, ProgressBar: THandle;
    fstart: TDateTime;

function DefWindowProc1(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
 WorkTime : String;
 Pos : integer;
begin
    if Msg = WM_TIMER then begin
        WorkTime:=TimeToStr(Frac(now)-Frac(fStart));
        SetWindowText(LabelTime,Pchar(WorkTime));
    end else
    Result := DefWindowProc(hWnd, Msg, wParam, lParam);
end;

procedure TWindowThread.WMShow1(var Msg: TThreadMessage);
var
  WndClassEx: TWNDCLASSEX;
  st: String;
  lFlags: Cardinal;
  lRect: TRect;
begin

if FWindowHandle = 0 then
  begin

    WndClassEx.cbSize := sizeOf(TWNDCLASSEX);
    WndClassEx.lpszClassName := 'PlainWindowThreadTest';
    WndClassEx.style := cs_VRedraw or cs_HRedraw;
    WndClassEx.hInstance := hInstance;
    WndClassEx.lpfnWndProc := @DefWindowProc1;
    WndClassEx.cbClsExtra := 0;
    WndClassEx.cbWndExtra := 0;
    WndClassEx.hIcon := LoadIcon(hInstance, MakeIntResource('MAINICON'));
    WndClassEx.hIconSm := LoadIcon(hInstance, MakeIntResource('MAINICON'));
    WndClassEx.hCursor := LoadCursor(0, idc_Arrow);;
    WndClassEx.hbrBackground := COLOR_BTNFACE + 1;
    WndClassEx.lpszMenuName := nil;

    RegisterClassEx(WndClassEx);

    // Главное окно
    FWindowHandle := CreateWindowEx(WS_EX_LAYERED, WndClassEx.lpszClassName, '...',
      WS_VISIBLE or WS_CLIPSIBLINGS or
    WS_CLIPCHILDREN or WS_OVERLAPPEDWINDOW
        , 100, 100, 370, 90, 0, 0, hInstance, nil);

    // Текст
    LabelText := CreateWindow('Static', 'Выполнение запроса...',
      WS_VISIBLE or WS_CHILD, 5, 10, 300, 15, FWindowHandle, 0,
      hInstance, nil);

    // Время ожидания
    LabelTime := CreateWindow('Static', '00:00',
      WS_VISIBLE or WS_CHILD, 295, 10, 300, 15, FWindowHandle, 0,
      hInstance, nil);

    // Прогресс
    ProgressBar := CreateWindow('msctls_progress32', '',
      WS_VISIBLE or WS_CHILD, 5, 30, 345, 15, FWindowHandle, 0,
      hInstance, nil);

    SendMessage(ProgressBar, PBM_SETRANGE, 0, MakeLong(0, 100));
    SendMessage(ProgressBar, PBM_SETPOS, 0, 0);

    SetLayeredWindowAttributes(FWindowHandle, RGB(255, 255, 255), 255,
      LWA_ALPHA);

  end;

  if FWindowHandle <> 0 then begin
        ShowWindow(FWindowHandle, SW_NORMAL);
        UpdateWindow(FWindowHandle);
        SetTimer(FWindowHandle, 1, 1000, nil);
  end;
end;

procedure TWindowThread.WMHide1(var Msg: TThreadMessage);
begin
    if FWindowHandle <> 0 then begin
        ShowWindow(FWindowHandle, SW_HIDE);
    end;
end;

end.