unit WThread2;

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

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

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

interface

uses
    Classes, SyncObjs, Variants;

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

    TWThread = class;

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

    { TWThread }

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

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

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

implementation

type

    { TGUIThread }

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

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

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

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

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

{ TGUIThread }

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

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

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

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

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

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

{ TWThread }

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

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

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

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

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

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

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

procedure TWThread.DirectTimeOut;
begin
    // override
end;

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

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

end.

unit LazMain;

interface

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

const
  WM_STRING = WM_USER+$120;

type
    { TMyThread }

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

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

var
  frmThreadTest: TfrmThreadTest;

implementation

{$R *.dfm}

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

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

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

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

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

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

{ TMyThread }

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

end.

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

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

interface

uses
    Classes,
    Windows,
    Messages;

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

type
    TWThread = class;

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

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

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

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

implementation

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

    SizeOfChar          = SizeOf(Char);

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

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

{ TWThread }

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

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

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

procedure TWThread.DirectTimeOut;
begin
    // override
end;

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

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

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

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

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

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

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

    while not Terminated do begin
        if not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE) then begin
            dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLINPUT);
            case dwHandleSignaled of
                WAIT_OBJECT_0: begin // выставлено событие остановки потока
                    if not FreeOnTerminate then
                        Terminate;
                    goto EndOfThread;
                end;
                WAIT_OBJECT_0 + 1: begin // получено сообщение
                    Continue;
                end;
                WAIT_TIMEOUT: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        PostMessageFromMe(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        case msg.message of
            WM_TIMEOUT: begin
                MSWait := msg.wParam;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Msg := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
end;

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

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

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

end.

object frmSearchMain: TfrmSearchMain
  Left = 0
  Top = 0
  Caption = 'Search Engine'
  ClientHeight = 312
  ClientWidth = 604
  Color = clBtnFace
  Constraints.MinHeight = 350
  Constraints.MinWidth = 620
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  ScreenSnap = True
  OnCloseQuery = FormCloseQuery
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  DesignSize = (
    604
    312)
  PixelsPerInch = 96
  TextHeight = 13
  object Label3: TLabel
    Left = 8
    Top = 189
    Width = 35
    Height = 13
    Caption = 'Results'
  end
  object memLog: TMemo
    Left = 8
    Top = 208
    Width = 588
    Height = 96
    Anchors = [akLeft, akTop, akRight, akBottom]
    ReadOnly = True
    ScrollBars = ssBoth
    TabOrder = 2
    OnDblClick = memLogDblClick
    ExplicitWidth = 636
    ExplicitHeight = 238
  end
  object butStart: TButton
    Left = 497
    Top = 22
    Width = 99
    Height = 25
    Hint = 'Start search'
    Anchors = [akTop, akRight]
    Caption = '&Start!'
    Default = True
    TabOrder = 1
    OnClick = butStartClick
    ExplicitLeft = 545
  end
  object Panel1: TPanel
    Left = 8
    Top = 8
    Width = 483
    Height = 170
    Anchors = [akLeft, akTop, akRight]
    BevelOuter = bvLowered
    Caption = 'Panel1'
    ShowCaption = False
    TabOrder = 0
    ExplicitWidth = 531
    DesignSize = (
      483
      170)
    object Label2: TLabel
      Left = 8
      Top = 56
      Width = 27
      Height = 13
      Caption = 'M&ask '
      FocusControl = edMask
    end
    object Label1: TLabel
      Left = 8
      Top = 8
      Width = 80
      Height = 13
      Caption = 'Start from &folder'
      FocusControl = edStart
    end
    object Label4: TLabel
      Left = 8
      Top = 104
      Width = 56
      Height = 13
      Caption = '&Text to find'
    end
    object cbInsensetive: TCheckBox
      Left = 152
      Top = 144
      Width = 121
      Height = 17
      Caption = '&Case insensetive'
      Checked = True
      State = cbChecked
      TabOrder = 5
    end
    object cbRecursive: TCheckBox
      Left = 8
      Top = 144
      Width = 129
      Height = 17
      Caption = '&Recursive'
      Checked = True
      State = cbChecked
      TabOrder = 4
    end
    object edMask: TEdit
      Left = 8
      Top = 75
      Width = 466
      Height = 21
      Anchors = [akLeft, akTop, akRight]
      TabOrder = 2
      TextHint = '*.txt;*.ini'
      OnChange = CheckControls
      ExplicitWidth = 514
    end
    object butSelect: TButton
      Left = 416
      Top = 22
      Width = 58
      Height = 25
      Hint = 'Select folder...'
      Anchors = [akTop, akRight]
      Caption = 'S&elect...'
      TabOrder = 1
      OnClick = butSelectClick
      ExplicitLeft = 464
    end
    object edStart: TEdit
      Left = 8
      Top = 24
      Width = 402
      Height = 21
      Anchors = [akLeft, akTop, akRight]
      TabOrder = 0
      TextHint = 'C:\Documents and Settings'
      OnChange = CheckControls
      ExplicitWidth = 450
    end
    object edText: TEdit
      Left = 8
      Top = 120
      Width = 466
      Height = 21
      Anchors = [akLeft, akTop, akRight]
      TabOrder = 3
      TextHint = 'What!?'
      ExplicitWidth = 514
    end
    object cbAnsi: TCheckBox
      Left = 295
      Top = 144
      Width = 43
      Height = 17
      Caption = 'A&NSI'
      Checked = True
      State = cbChecked
      TabOrder = 6
      OnClick = CheckCodePages
    end
    object cbUTF8: TCheckBox
      Left = 363
      Top = 144
      Width = 57
      Height = 17
      Caption = 'UTF&8'
      TabOrder = 7
      OnClick = CheckCodePages
    end
    object cbUTF16: TCheckBox
      Left = 426
      Top = 144
      Width = 49
      Height = 17
      Caption = 'UTF1&6'
      TabOrder = 8
      OnClick = CheckCodePages
    end
  end
  object progress: TProgressBar
    Left = 48
    Top = 189
    Width = 548
    Height = 13
    Anchors = [akLeft, akTop, akRight]
    TabOrder = 3
    Visible = False
    ExplicitWidth = 596
  end
  object timerUpdateCaption: TTimer
    Enabled = False
    OnTimer = timerUpdateCaptionTimer
    Left = 744
    Top = 104
  end
end

unit SearchMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, FileCtrl, WThread,
  Generics.Collections, Types, StrUtils, ShellApi, Vcl.ComCtrls;

const
  //WM_THREAD_BASE            = WM_USER + $100;
  WM_SCAN_FOLDERS_START     = WM_THREAD_BASE + 1;
  WM_SCAN_FOLDERS_ADD       = WM_THREAD_BASE + 2;
  WM_SCAN_FOLDERS_END       = WM_THREAD_BASE + 3;
  WM_SEARCH_START           = WM_THREAD_BASE + 4;
  WM_SEARCH_MATCH           = WM_THREAD_BASE + 20;
  WM_SEARCH_END             = WM_THREAD_BASE + 6;
  WM_ACCESS_DENIED          = WM_THREAD_BASE + 10;

type
  TWorkFlow = class(TObject)
  public
    Path: string;
    Scaning: boolean;
    Scaned: boolean;
    constructor Create(const APath: string);
    procedure SetScaning;
    procedure SetScaned;
  end;

  TScanFolders = class(TWThread)
  private
    FPath: string;
    FMask: string;
  protected
    procedure ScanFoldersStart(var Msg: TThreadMessage); message WM_SCAN_FOLDERS_START;
  public
    property Path: string read FPath write FPath;
    property Mask: string read FMask write FMask;
  end;

  TSearchFiles = class(TWThread)
  private
    FPath: string;
    FMask: string;
    FCaseIns: boolean;
    FText: string;
    FAsAnsi: boolean;
    FAsUtf8: boolean;
    FAsUtf16: boolean;
    FAnsiBuf: TBytes;
    FUndoSeek: integer;
    procedure SetText(const Value: string);
    procedure SetCaseIns(const Value: boolean);
  protected
    procedure SearchStart(var Msg: TThreadMessage); message WM_SEARCH_START;
    property undoSeek: integer read FUndoSeek;
  public
    property Path: string read FPath write FPath;
    property Mask: string read FMask write FMask;
    property CaseIns: boolean read FCaseIns write SetCaseIns;
    property AsAnsi: boolean read FAsAnsi write FAsAnsi;
    property AsUtf8: boolean read FAsUtf8 write FAsUtf8;
    property AsUtf16: boolean read FAsUtf16 write FAsUtf16;
    property Text: string read FText write SetText;
  end;

  TfrmSearchMain = class(TForm)
    Label3: TLabel;
    memLog: TMemo;
    butStart: TButton;
    Panel1: TPanel;
    cbInsensetive: TCheckBox;
    cbRecursive: TCheckBox;
    edMask: TEdit;
    Label2: TLabel;
    butSelect: TButton;
    edStart: TEdit;
    Label1: TLabel;
    timerUpdateCaption: TTimer;
    Label4: TLabel;
    edText: TEdit;
    progress: TProgressBar;
    cbAnsi: TCheckBox;
    cbUTF8: TCheckBox;
    cbUTF16: TCheckBox;
    procedure timerUpdateCaptionTimer(Sender: TObject);
    procedure CheckControls(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure memLogDblClick(Sender: TObject);
    procedure CheckCodePages(Sender: TObject);
    procedure butSelectClick(Sender: TObject);
    procedure butStartClick(Sender: TObject);
  private
    FSearching: boolean;
    FUpdateIndex: integer;
    FFoldersList: TList<TWorkFlow>;
    procedure SetSearching(const Value: boolean);
    procedure UpdateControls;
    procedure StartSearch;
    procedure StopSearch;
    procedure OnReceive(Sender: TWThread; var Msg: TThreadMessage);
    procedure AddToLog(const AText: string);
    function GetThread: TSearchFiles;
  public
    procedure UpdateCaption;
    property Searching: boolean read FSearching write SetSearching;
  end;

var
  frmSearchMain: TfrmSearchMain;
  arrThreads: array of TSearchFiles;
  ScanThread: TScanFolders;
  SearchCount, FilesCount: integer;
  MAX_THREADS: integer;

implementation

{$R *.dfm}

function Min(A1, A2: Integer): Integer;
begin
    if A1 > A2 then Result := A2
    else Result := A1;
end;

{ TfrmSearchMain }

procedure TfrmSearchMain.AddToLog(const AText: string);
begin
    memLog.Lines.Add(Format('%s | %s', [FormatDateTime('hh.nn.ss.zzz', Now), AText]));
end;

procedure TfrmSearchMain.butSelectClick(Sender: TObject);
var s: string;
begin
    s := edStart.Text;
    if SelectDirectory('', '', s, [sdNewUI]) then begin
        edStart.Text := s;
        UpdateControls;
    end;
end;

procedure TfrmSearchMain.butStartClick(Sender: TObject);
begin
    if Searching and (MessageDlg('You are sure?!', mtConfirmation, mbYesNo, 0) = mrYes) then begin
        Searching := False;
        AddToLog('Cancel operation.');
    end else if not Searching then begin
        Searching := true;
    end;
end;

procedure TfrmSearchMain.CheckCodePages(Sender: TObject);
begin
    if (not cbAnsi.Checked) and (not cbUTF8.Checked) and (not cbUTF16.Checked) then
        cbAnsi.Checked := true;
end;

procedure TfrmSearchMain.CheckControls(Sender: TObject);
begin
    UpdateControls;
end;

procedure TfrmSearchMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
    CanClose := (not Searching)or(MessageDlg('You are sure?', mtConfirmation, mbYesNo, 0) = mrYes);
    if Searching and CanClose then
        StopSearch;
end;

procedure TfrmSearchMain.FormCreate(Sender: TObject);
begin
    MAX_THREADS := TThread.ProcessorCount * 2;
    ScanThread := TScanFolders.Create;
    ScanThread.OnThreadReceiveMessage := OnReceive;
    FFoldersList := TList<TWorkFlow>.Create;
    UpdateControls;
end;

procedure TfrmSearchMain.FormDestroy(Sender: TObject);
begin
    FFoldersList.Free;
    ScanThread.StopThread;
    ScanThread.Free;
end;

function TfrmSearchMain.GetThread: TSearchFiles;
begin
    Result := TSearchFiles.Create;
    with Result do begin
        Mask := edMask.Text;
        Text := edText.Text;
        CaseIns := cbInsensetive.Checked;
        AsAnsi := cbAnsi.Checked;
        AsUtf8 := cbUTF8.Checked;
        AsUtf16 := cbUTF16.Checked;
        OnThreadReceiveMessage := OnReceive;
    end;
end;

procedure TfrmSearchMain.memLogDblClick(Sender: TObject);
var s: string;
    i: integer;
begin
    s := memLog.Lines[memLog.Perform(EM_LINEFROMCHAR, memLog.SelStart, 0)];
    i := Pos('Match found: ', s);
    if i > 0 then begin
        s := '/select, '+Copy(s, i+13, 1024);
        ShellExecute(Application.Handle,'OPEN','EXPLORER',PWideChar(s),'',SW_NORMAL)
    end;
end;

procedure TfrmSearchMain.SetSearching(const Value: boolean);
begin
    if Value <> FSearching then begin
        FSearching := Value;
        if FSearching then begin
            progress.Max := 0;
            progress.Position := 0;
            progress.Show;
            butStart.Caption := 'Stop!';
            FUpdateIndex := 0;
            UpdateCaption;
            timerUpdateCaption.Enabled := True;
            UpdateControls;
            StartSearch;
        end else begin
            progress.Hide;
            butStart.Caption := 'Start!';
            timerUpdateCaption.Enabled := false;
            UpdateCaption;
            UpdateControls;
            StopSearch;
        end;
    end;
end;

procedure TfrmSearchMain.StartSearch;
var i: integer;
    wf: TWorkFlow;
begin
    if cbRecursive.Checked then begin
        SetLength(arrThreads, MAX_THREADS);
        for i := Low(arrThreads) to High(arrThreads) do begin
            arrThreads[i] := GetThread;
        end
    end else begin
        SetLength(arrThreads, 1);
        arrThreads[0] := GetThread;
    end;
    SleepEx(20, True);
    SearchCount := 0;
    FilesCount := 0;
    memLog.Lines.Clear;
    if cbRecursive.Checked then begin
        AddToLog('Preparing folders...');
        ScanThread.Path := edStart.Text;
        ScanThread.Mask := edMask.Text;
        ScanThread.PostToThreadMessage(WM_SCAN_FOLDERS_START, 1, 0);
    end else begin
        AddToLog('Start Search engine...');
        wf := TWorkFlow.Create(IncludeTrailingBackslash(edStart.Text));
        FFoldersList.Add(wf);
        arrThreads[0].PostToThreadMessage(WM_SEARCH_START, 1, NewString(wf.Path));
    end;
end;

procedure TfrmSearchMain.StopSearch;
var i: integer;
begin
    for I := Low(arrThreads) to High(arrThreads) do
        if Assigned(arrThreads[i]) then begin
            arrThreads[i].StopThread;
            arrThreads[i].Free;
            arrThreads[i] := nil;
        end;
    for i := 0 to FFoldersList.Count-1 do
        FFoldersList[i].Free;
    FFoldersList.Clear;
end;

procedure TfrmSearchMain.timerUpdateCaptionTimer(Sender: TObject);
begin
    UpdateCaption;
end;

procedure TfrmSearchMain.UpdateCaption;
var s: string;
begin
    if not Searching then
        Caption := 'Search Engine'
    else begin
        Inc(FUpdateIndex);
        case FUpdateIndex mod 4 of
            0: s := '|';
            1: s := '/';
            2: s := '-';
            3: s := '\';
        end;
        Caption := Format('(%s) Search Engine', [s]);
    end;
end;

procedure TfrmSearchMain.UpdateControls;
begin
    butStart.Enabled := Searching or (Length(edStart.Text) + Length(edMask.Text) > 4);
    butSelect.Enabled := not Searching;
    edStart.Enabled := not Searching;
    edMask.Enabled := not Searching;
    cbInsensetive.Enabled := not Searching;
    cbRecursive.Enabled := not Searching;
    cbAnsi.Enabled := not Searching;
    cbUTF8.Enabled := not Searching;
    cbUTF16.Enabled := not Searching;
end;

procedure TfrmSearchMain.OnReceive(Sender: TWThread; var Msg: TThreadMessage);
var i, x: integer;

    function GetPathIndex(const APath: string): integer;
    var i: integer;
    begin
        for i := 0 to FFoldersList.Count-1 do
            if CompareText(FFoldersList[i].Path, APath) = 0 then
                Exit(i);
        result := -1;
    end;

    function GetNextToSend: integer;
    var i: integer;
    begin
        for i := 0 to FFoldersList.Count-1 do
            if (not FFoldersList[i].Scaning) and (not FFoldersList[i].Scaned) then
                Exit(i);
        result := -1;
    end;

    function AllScaned: boolean;
    var i: integer;
    begin
        for i := 0 to FFoldersList.Count-1 do
            if not FFoldersList[i].Scaned then
                Exit(false);
        result := true;
    end;

    function IsScanning: boolean;
    var i: integer;
    begin
        for i := 0 to FFoldersList.Count-1 do
            if FFoldersList[i].Scaning then
                Exit(true);
        result := false;
    end;

begin
    if Searching then
    case Msg.Message of
        WM_SCAN_FOLDERS_END: begin
            if FFoldersList.Count > 0 then begin
                AddToLog(Format('Prepared %d folder(s). Start Search engine...', [FFoldersList.Count]));
                x := Min(FFoldersList.Count-1, High(arrThreads));
                for i := 0 to x do begin
                    arrThreads[i].PostToThreadMessage(WM_SEARCH_START, 1, NewString(FFoldersList[i].Path));
                    FFoldersList[i].SetScaning;
                end;
                progress.Max := FFoldersList.Count;
            end else begin
                AddToLog('Prepared 0 folder(s). Search engine not started.');
                Searching := false;
            end;
        end;
        WM_SCAN_FOLDERS_ADD: begin
            FFoldersList.Add(TWorkFlow.Create(FreeString(Msg.LParam)));
        end;
        WM_SEARCH_MATCH: begin
            AddToLog(Format('Match found: %s', [FreeString(Msg.LParam)]));
            Inc(FilesCount);
        end;
        WM_ACCESS_DENIED: begin
            AddToLog(Format('Access error: %s', [FreeString(Msg.LParam)]));
        end;
        WM_SEARCH_END: begin
            Inc(SearchCount);
            i := GetPathIndex(TSearchFiles(Sender).Path);
            FFoldersList[i].SetScaned;
            if not AllScaned then begin
                i := GetNextToSend;
                if i <> -1 then begin
                    Sender.PostToThreadMessage(WM_SEARCH_START, 1, NewString(FFoldersList[i].Path));
                    FFoldersList[i].SetScaning;
                end;
            end else if not IsScanning then begin
                AddToLog(Format('Stop search engine. %d file(s) found.', [FilesCount]));
                Searching := false;
            end;
            progress.Position := SearchCount;
        end;
    end;
end;

{ TScanFolders }

procedure TScanFolders.ScanFoldersStart(var Msg: TThreadMessage);

    procedure Search(const APath, AMask: string);
    var sr: TSearchRec;
        i: integer;
        ar: TStringDynArray;
    begin
        ar := SplitString(AMask, ';, ');
        for i := Low(ar) to High(ar) do
            if (not Terminated) and (FindFirst(APath + Trim(ar[i]), faReadOnly or faArchive, sr) = 0) then begin
                PostMessageFromThread(WM_SCAN_FOLDERS_ADD, 0, NewString(APath));
                break;
            end else
                FindClose(sr);
        FindClose(sr);
        if FindFirst(APath + '*', faDirectory, sr) = 0 then begin
            repeat
                if LongBool((sr.Attr and faDirectory)) then begin
                    if (sr.Name <> '.') and (sr.Name <> '..') then
                        Search(IncludeTrailingBackslash(APath+sr.Name), AMask);
                end;
            until LongBool(FindNext(sr)) or Terminated;
            FindClose(sr);
        end;
    end;

begin
    Search(IncludeTrailingBackslash(Path), Mask);
    PostMessageFromThread(WM_SCAN_FOLDERS_END, 0, 0);
end;

{ TSearchFiles }

procedure TSearchFiles.SearchStart(var Msg: TThreadMessage);
var buf: TBytes;
    resu: boolean;

    procedure UpperArray(var arr: TBytes; const len: integer);
    var l: integer;
    begin
        if len = -1 then
            l := Length(arr)
        else
            l := len;
        CharUpperBuffA(@arr[0], l);
    end;

    function ScanArray(const buf: TBytes; const size: integer): boolean;
    var x, y, hw: integer;
    begin
        result := false;
        hw := high(FAnsiBuf);
        for x := Low(buf) to Min(High(buf), size)-high(FAnsiBuf) do begin
            if buf[x] = FAnsiBuf[0] then
                for y := 1 to hw do
                    if buf[x+y] <> FAnsiBuf[y] then
                        break
                    else if y = hw then
                        Exit(true);
        end;
    end;

    procedure ScanFile(const AFileName: string);
    var f: file;
        res: integer;
        io: integer;

        function ScanAnsi(buf: TBytes; const len: integer): boolean;
        var b: TBytes;
        begin
            if CaseIns then begin
                SetLength(b, Length(buf));
                Move(buf[0], b[0], len);
                UpperArray(b, len);
                result := ScanArray(b, len);
            end else begin
                result := ScanArray(buf, len);
            end;
        end;

        function ScanUtf8(buf: TBytes; const len: integer): boolean;
        var b: TBytes;
            s: string;
        begin
            b := TEncoding.Convert(TEncoding.UTF8, TEncoding.ANSI, buf, 0, len);
            if CaseIns then
                UpperArray(b, -1);
            result := ScanArray(b, length(b));
        end;

        function ScanUtf16(buf: TBytes; const len: integer): boolean;
        var b: TBytes;
        begin
            b := TEncoding.Convert(TEncoding.Unicode, TEncoding.ANSI, buf, 0, len);
            if CaseIns then
                UpperArray(b, -1);
            result := ScanArray(b, length(b));
        end;

    begin
        {$I-}
        FileMode := fmOpenRead;
        AssignFile(f, AFileName);
        Reset(f, 1);
        io := IOResult;
        if io = 0 then begin
            repeat
                BlockRead(f, buf[0], Length(buf), res);
                if AsUtf8 or AsUtf16 then begin
                    resu := (AsAnsi and ScanAnsi(buf, res-1))
                        or (AsUtf8 and ScanUtf8(buf, res))
                        or (AsUtf16 and ScanUtf16(buf, res));
                end else begin
                    if CaseIns then
                        UpperArray(buf, res);
                    resu := ScanArray(buf, res-1);
                end;
                if resu then begin
                    PostMessageFromThread(WM_SEARCH_MATCH, 0, NewString(AFileName));
                    Break;
                end;
                if (not Eof(F)) then
                    Seek(F, FilePos(F)-undoSeek);
            until (Length(buf) <> res) or (Terminated);
            CloseFile(f);
        end else begin
            PostMessageFromThread(WM_ACCESS_DENIED, 0, NewString(Format('%s [%d]', [AFileName, io])));
        end;
        IOResult;
        {$I+}
    end;

    procedure Search(const APath, AMask: string);
    var sr: TSearchRec;
        i: integer;
        ar: TStringDynArray;
    begin
        ar := SplitString(AMask, ';, ');
        for i := Low(ar) to High(ar) do begin
            if FindFirst(APath + Trim(ar[i]), faReadOnly or faArchive, sr) = 0 then begin
                repeat
                    ScanFile(APath + sr.Name);
                until LongBool(FindNext(sr)) or Terminated;
                FindClose(sr);
            end;
        end;
    end;

begin
    Path := FreeString(Msg.LParam);
    SetLength(buf, 65534);
    FUndoSeek := Length(FAnsiBuf)-1;
    if AsUtf16 then
        FUndoSeek := FUndoSeek * 2;
    Search(Path, Mask);
    PostMessageFromThread(WM_SEARCH_END, 0, NewString(Path));
end;

procedure TSearchFiles.SetCaseIns(const Value: boolean);
begin
    FCaseIns := Value;
    Text := Text;
end;

procedure TSearchFiles.SetText(const Value: string);

    function GetAsAnsi(const S: String): TBytes;
    var b: TBytes;
    begin
        SetLength(b, Length(s)*SizeOf(Char));
        Move(s[1], b[0], Length(b));
        Result := TEncoding.Convert(TEncoding.Unicode, TEncoding.ANSI, b);
    end;

begin
    FText := Value;
    if Length(Value) > 0 then begin
        FAnsiBuf := GetAsAnsi(Value);
        if CaseIns then
            CharUpperBuffA(@FAnsiBuf[0], Length(FAnsiBuf));
    end else begin
        SetLength(FAnsiBuf, 0);
    end;
end;

{ TWorkFlow }

constructor TWorkFlow.Create(const APath: string);
begin
    Path := APath;
    Scaned := false;
    Scaning := false;
end;

procedure TWorkFlow.SetScaned;
begin
    Scaned := true;
    Scaning := false;
end;

procedure TWorkFlow.SetScaning;
begin
    Scaned := false;
    Scaning := true;
end;

end.

unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, версия от 08.11.2013
//
// использование:
// 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

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

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

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

interface

uses
    Classes,
    Messages
{$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}
        procedure WWindowProc(var Msg: TMessage);
{$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;
    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 FTimeOut write SetTimeOut default INFINITE;
            // true = Будет вызван DirectTimeOut из этого потока, false = вызвано событие OnTimeOut в основном потоке.
        property TimeOutIsDirect: boolean read FTimeOutIsDirect write FTimeOutIsDirect default false;
    end;

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

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

implementation

{$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}
    FToolWindow := AllocateHWnd(WWindowProc);
    hCloseEvent := CreateEvent(nil, true, false, nil);
{$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);
    DeallocateHWnd(FToolWindow);
{$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, 0, WM_USER, WM_USER, PM_NOREMOVE);
    HandlesToWaitFor[0] := hCloseEvent;
    // SleepEx не нужен, если подготовительный код до цикла while будет достаточно долго выполняться
    // уточняется опытным путем, иначе очередь сообщений потока не успеет запуститься и сообщения могут улететь в пустоту
    //SleepEx(20, true);

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

    while not Terminated do begin
        if not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE) then begin
            dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLINPUT);
            case dwHandleSignaled of
                WAIT_OBJECT_0: begin // выставлено событие остановки потока
                    if not FreeOnTerminate then
                        Terminate;
                    goto EndOfThread;
                end;
                WAIT_OBJECT_0 + 1: begin // получено сообщение
                    Continue;
                end;
                WAIT_TIMEOUT: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        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
        PostMessage(FToolWindow, Msg, WParam, LParam);
{$ENDIF}
end;

procedure TWThread.StopThread;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.SetEvent;
{$ELSE}
    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
        Msg.Result := DefWindowProc(FToolWindow, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;
{$ENDIF}

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;

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 1000 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 }

function DefWindowProc1(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin
    Result := DefWindowProc(hWnd, Msg, wParam, lParam);
end;

procedure TWindowThread.WMShow1(var Msg: TThreadMessage);
var
    WndClassEx:  TWNDCLASSEX;
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 := CreateSolidBrush ($ccffff);
        WndClassEx.lpszMenuName := nil;

        RegisterClassEx(WndCLassEx);

        FWindowHandle := CreateWindowEx(0,WndClassEx.lpszClassName,'First_WinAPI_Programm',
            WS_popup or WS_BORDER or WS_EX_TRANSPARENT or WS_EX_TOPMOST or WS_CAPTION or WS_DLGFRAME
            ,100,100,584,630,0,0,HInstance,nil);

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

    end;

    ShowWindow(FWindowHandle, SW_NORMAL);
end;

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

end.

unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, версия от 08.11.2013
//
// использование:
// 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

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

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

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

interface

uses
    Classes,
    Messages
{$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);
{$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;
    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 FTimeOut write SetTimeOut default INFINITE;
            // true = Будет вызван DirectTimeOut из этого потока, false = вызвано событие OnTimeOut в основном потоке.
        property TimeOutIsDirect: boolean read FTimeOutIsDirect write FTimeOutIsDirect default false;
    end;

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

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

implementation

{$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}
    FToolWindow := AllocateHWnd(WWindowProc);
    hCloseEvent := CreateEvent(nil, true, false, nil);
    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);
    DeallocateHWnd(FToolWindow);
{$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 := FTimeOut; // изменяя кол-во миллисекунд в 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
        PostMessage(FToolWindow, Msg, WParam, LParam);
{$ENDIF}
end;

procedure TWThread.StopThread;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.SetEvent;
{$ELSE}
    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
        Msg.Result := DefWindowProc(FToolWindow, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;
{$ENDIF}

end.