utils/uutlEventManager.pas

unit uutlEventManager;

{ Package:      Utils
  Prefix:       utl - UTiLs
  Beschreibung: diese Unit verwaltet Events und verteilt diese an registrierte Programm-Teile }

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, syncobjs, Controls,
  uutlGenerics;

type
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlEventManager = class(TObject)
  public type
    TEventType     = 0..63;
    TEventTypeMask = UInt64;

    ////////////////////////////////////////////////////////////////////////////
    TEvent = class
    public
      EventType: TEventType;
      Timestamp: QWord;

      function Clone: TEvent;
      procedure Assign(const aEvent: TEvent); virtual;
      constructor Create; virtual;
    end;
    TEventClass = class of TEvent;
    TEventList = specialize TutlList<TEvent>;

    ////////////////////////////////////////////////////////////////////////////
    TEventListener = class(TObject)
    public
      function DispatchEvent(const aEvent: TEvent): Boolean; virtual;
    end;
    TEventListenerSet = specialize TutlHashSet<TEventListener>;

    ////////////////////////////////////////////////////////////////////////////
    TEventHandlerCallback = procedure(aSender: TObject; aEvent: TEvent) of object;
    TCallbackEventListener = class(TEventListener)
    public
      Callback: TEventHandlerCallback;
      Filter: TEventTypeMask;
      function DispatchEvent(const aEvent: TEvent): Boolean; override;
    end;

  private
    fEventQueue:      TEventList;
    fEventQueueLock:  TCriticalSection;
    fEventListener:   TEventListenerSet;

    procedure DispatchEvent(const aEvent: TEvent);
  protected
    procedure PushEvent(const aEvent: TEvent); virtual;
    procedure RecordEvent(const aEvent: TEvent); virtual;
  public
    procedure RegisterListener(const aEventMask: TEventTypeMask; const aCallback: TEventHandlerCallback);
    procedure RegisterListener(const aListener: TEventListener);

    procedure UnregisterListener(const aHandler: TEventHandlerCallback);
    procedure UnregisterListener(const aListener: TEventListener);

    procedure DispatchEvents;

    constructor Create;
    destructor Destroy; override;

  public
    class function MakeMask    (const aTypes: array of TEventType): TEventTypeMask;
    class function CombineMasks(const aMasks: array of TEventTypeMask): TEventTypeMask;
    class function MaskHasType (const aMask: TEventTypeMask; const aType: TEventType): Boolean; inline;
  end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlWinControlEventManager = class(TutlEventManager)
  public type
    ////////////////////////////////////////////////////////////////////////////
    TMouseEvent = class(TEvent)
    public
      Button: TMouseButton;
      ClientPos: TPoint;
      ScreenPos: TPoint;
      procedure Assign(const aEvent: TEvent); override;
    end;

    ////////////////////////////////////////////////////////////////////////////
    TMouseWheelEvent = class(TEvent)
    public
      WheelDelta: Integer;
      ClientPos: TPoint;
      ScreenPos: TPoint;
      procedure Assign(const aEvent: TEvent); override;
    end;

    ////////////////////////////////////////////////////////////////////////////
    TKeyEvent = class(TEvent)
    public
      CharCode: WideChar;
      KeyCode: Word;
      procedure Assign(const aEvent: TEvent); override;
    end;

    ////////////////////////////////////////////////////////////////////////////
    TWindowEvent = class(TEvent)
    public
      ScreenRect: TRect;
      ClientWidth: Cardinal;
      ClientHeight: Cardinal;
      procedure Assign(const aEvent: TEvent); override;
    end;

    ////////////////////////////////////////////////////////////////////////////
    TMouseButtons = set of TMouseButton;
    TKeyboardState = record
      Modifiers: TShiftState;
      KeyState: array[Byte] of Boolean;
    end;
    TMouseState = record
      ScreenPos, ClientPos: TPoint;
      Buttons: TMouseButtons;
    end;
    TWindowState = record
      Active: boolean;
      ScreenRect: TRect;
      ClientWidth: Integer;
      ClientHeight: Integer;
    end;

  public const
    MOUSE_DOWN        =  0;
    MOUSE_UP          =  1;
    MOUSE_WHEEL_UP    =  2;
    MOUSE_WHEEL_DOWN  =  3;
    MOUSE_MOVE        =  4;
    MOUSE_ENTER       =  5;
    MOUSE_LEAVE       =  6;
    MOUSE_CLICK       =  7;
    MOUSE_DBL_CLICK   =  8;

    KEY_DOWN          = 10;
    KEY_REPEAT        = 11;
    KEY_UP            = 12;

    WINDOW_RESIZE     = 15;
    WINDOW_ACTIVATE   = 16;
    WINDOW_DEACTIVATE = 17;

    EVENTS_MOUSE: TEventTypeMask =
      (1 shl MOUSE_DOWN)        or
      (1 shl MOUSE_UP)          or
      (1 shl MOUSE_WHEEL_UP)    or
      (1 shl MOUSE_WHEEL_DOWN)  or
      (1 shl MOUSE_MOVE)        or
      (1 shl MOUSE_ENTER)       or
      (1 shl MOUSE_LEAVE)       or
      (1 shl MOUSE_CLICK)       or
      (1 shl MOUSE_DBL_CLICK);
    EVENTS_KEYBOARD: TEventTypeMask =
      (1 shl KEY_DOWN)          or
      (1 shl KEY_REPEAT)        or
      (1 shl KEY_UP);
    EVENTS_WINDOW: TEventTypeMask =
      (1 shl WINDOW_RESIZE)     or
      (1 shl WINDOW_ACTIVATE)   or
      (1 shl WINDOW_DEACTIVATE);
  private
    fKeyboard: TKeyboardState;
    fMouse: TMouseState;
    fWindow: TWindowState;

  private
    procedure HandlerMouseDown  (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure HandlerMouseUp    (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure HandlerMouseMove  (Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure HandlerMouseEnter (Sender: TObject);
    procedure HandlerMouseLeave (Sender: TObject);
    procedure HandlerClick      (Sender: TObject);
    procedure HandlerDblClick   (Sender: TObject);
    procedure HandlerMouseWheel (Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);

    procedure HandlerKeyDown    (Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure HandlerKeyUp      (Sender: TObject; var Key: Word; Shift: TShiftState);

    procedure HandlerResize     (Sender: TObject);
    procedure HandlerActivate   (Sender: TObject);
    procedure HandlerDeactivate (Sender: TObject);

  protected
    procedure RecordEvent(const aEvent: TEvent); override;

  protected
    function CreateMouseEvent     (aEvent: TMouseEvent; aType: TEventType; aButton: TMouseButton; aClientPos, aScreenPos: TPoint): TMouseEvent; virtual;
    function CreateMouseWheelEvent(aEvent: TMouseWheelEvent; aSender: TWinControl; aDelta: Integer; aClientPos: TPoint): TMouseWheelEvent; virtual;
    function CreateKeyEvent       (aEvent: TKeyEvent; aType: TEventType; aKey: Word): TKeyEvent; virtual;
    function CreateWindowEvent    (aEvent: TWindowEvent; aType: TEventType; aSender: TControl): TWindowEvent; virtual;

  public
    property Keyboard: TKeyboardState read fKeyboard;
    property Mouse:    TMouseState    read fMouse;
    property Window:   TWindowState   read fWindow;

    procedure AttachEvents(const aControl: TWinControl; const aMask: TEventTypeMask);
  end;

implementation

uses
  LCLIntf, Forms,
  uutlTiming, uutlConversion, uutlKeyCodes;

type
  TWinControlVisibilityClass = class(TWinControl)
  published
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnClick;
    property OnDblClick;
  end;

  TCustomFormVisibilityClass = class(TCustomForm)
  published
    property OnActivate;
    property OnDeactivate;
  end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventManager.TEvent////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventManager.TEvent.Clone: TEvent;
begin
  result := TEventClass(ClassType).Create;
  result.Assign(self);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.TEvent.Assign(const aEvent: TEvent);
begin
  Timestamp := aEvent.Timestamp;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventManager.TEvent.Create;
begin
  inherited Create;
  Timestamp := GetMicroTime;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventManager.TEventListener////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventManager.TEventListener.DispatchEvent(const aEvent: TEvent): Boolean;
begin
  result := false;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventManager.TCallbackEventListener////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventManager.TCallbackEventListener.DispatchEvent(const aEvent: TEvent): Boolean;
begin
  result := inherited DispatchEvent(aEvent);
  if TutlEventManager.MaskHasType(Filter, aEvent.EventType) then
     Callback(self, aEvent);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventManager///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.DispatchEvent(const aEvent: TEvent);
var
  l: TEventListener;
begin
  for l in fEventListener do begin
    if l.DispatchEvent(aEvent) then
       break;
  end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.PushEvent(const aEvent: TEvent);
begin
  fEventQueueLock.Enter;
  try
    if Assigned(fEventQueue) then
       fEventQueue.Add(aEvent)
    else if Assigned(aEvent) then
       aEvent.Free;
  finally
    fEventQueueLock.Leave;
  end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.RecordEvent(const aEvent: TEvent);
begin
  // DUMMY
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.RegisterListener(const aEventMask: TEventTypeMask; const aCallback: TEventHandlerCallback);
var
  l: TCallbackEventListener;
begin
  UnregisterListener(aCallback);
  l := TCallbackEventListener.Create;
  try
    l.Filter   := aEventMask;
    l.Callback := aCallback;
    RegisterListener(l);
  except
    FreeAndNil(l);
  end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.RegisterListener(const aListener: TEventListener);
begin
  fEventListener.Add(aListener);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.UnregisterListener(const aHandler: TEventHandlerCallback);
var
  i: Integer;
  m1, m2: TMethod;
  cel: TCallbackEventListener;
begin
  m1 := TMethod(aHandler);
  for i := fEventListener.Count-1 downto 0 do
    if Supports(fEventListener[i], TCallbackEventListener, cel) then begin
      m2 := TMethod(cel.Callback);
      if (m1.Data = m2.Data) and
         (m1.Code = m2.Code) then
         fEventListener.Delete(i);
    end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.UnregisterListener(const aListener: TEventListener);
begin
  fEventListener.Remove(aListener);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.DispatchEvents;
var
  e: TEvent;
begin
  fEventQueueLock.Acquire;
  try
    if Assigned(fEventQueue) then begin
      for e in fEventQueue do begin
        DispatchEvent(e);
        RecordEvent(e);
      end;
      fEventQueue.Clear;
    end;
  finally
    fEventQueueLock.Release;
  end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventManager.Create;
begin
  inherited Create;
  fEventListener  := TEventListenerSet.Create(true);
  fEventQueue     := TEventList.Create(true);
  fEventQueueLock := TCriticalSection.Create;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TutlEventManager.Destroy;
begin
  fEventQueueLock.Enter;
  try
    FreeAndNil(fEventQueue);
  finally
    fEventQueueLock.Leave;
  end;
  FreeAndNil(fEventQueueLock);
  FreeAndNil(fEventListener);
  inherited Destroy;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEventManager.MakeMask(const aTypes: array of TEventType): TEventTypeMask;
var
  e: TEventType;
begin
  result := 0;
  for e in aTypes do
    result := result or (1 shl e);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEventManager.CombineMasks(const aMasks: array of TEventTypeMask): TEventTypeMask;
var
  m: TEventTypeMask;
begin
  result := 0;
  for m in aMasks do
    result := result or m;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEventManager.MaskHasType(const aMask: TEventTypeMask; const aType: TEventType): Boolean;
begin
  result := ((aMask and (1 shl aType)) <> 0);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWinControlEventManager.TMouseEvent/////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.TMouseEvent.Assign(const aEvent: TEvent);
var
  me: TMouseEvent;
begin
  inherited Assign(aEvent);
  if Supports(aEvent, TMouseEvent, me) then begin
    Button    := me.Button;
    ClientPos := me.ClientPos;
    ScreenPos := me.ScreenPos;
  end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWinControlEventManager.TMouseWheelEvent////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.TMouseWheelEvent.Assign(const aEvent: TEvent);
var
  mwe: TMouseWheelEvent;
begin
  inherited Assign(aEvent);
  if Supports(aEvent, TMouseWheelEvent, mwe) then begin
    WheelDelta := mwe.WheelDelta;
    ClientPos  := mwe.ClientPos;
    ScreenPos  := mwe.ScreenPos;
  end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWinControlEventManager.TKeyEvent///////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.TKeyEvent.Assign(const aEvent: TEvent);
var
  ke: TKeyEvent;
begin
  inherited Assign(aEvent);
  if Supports(aEvent, TKeyEvent, ke) then begin
    CharCode := ke.CharCode;
    KeyCode  := ke.KeyCode;
  end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWinControlEventManager.TWindowEvent////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.TWindowEvent.Assign(const aEvent: TEvent);
var
  we: TWindowEvent;
begin
  inherited Assign(aEvent);
  if Supports(aEvent, TWindowEvent, we) then begin
    ScreenRect   := we.ScreenRect;
    ClientWidth  := we.ClientWidth;
    ClientHeight := we.ClientHeight;
  end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWinControlEventManager/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  PushEvent(CreateMouseEvent(nil, MOUSE_DOWN, Button, Point(X, Y), TWinControl(Sender).ClientToScreen(Point(X, Y))));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  PushEvent(CreateMouseEvent(nil, MOUSE_UP, Button, Point(X, Y), TWinControl(Sender).ClientToScreen(Point(X, Y))));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  PushEvent(CreateMouseEvent(nil, MOUSE_MOVE, mbLeft, Point(X, Y), TWinControl(Sender).ClientToScreen(Point(X, Y))));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseEnter(Sender: TObject);
begin
  PushEvent(CreateMouseEvent(nil, MOUSE_ENTER, mbLeft, TWinControl(Sender).ScreenToClient(Controls.Mouse.CursorPos), Controls.Mouse.CursorPos));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseLeave(Sender: TObject);
begin
  PushEvent(CreateMouseEvent(nil, MOUSE_LEAVE, mbLeft, TWinControl(Sender).ScreenToClient(Controls.Mouse.CursorPos), Controls.Mouse.CursorPos));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerClick(Sender: TObject);
begin
  PushEvent(CreateMouseEvent(nil, MOUSE_CLICK, mbLeft, TWinControl(Sender).ScreenToClient(Controls.Mouse.CursorPos), Controls.Mouse.CursorPos));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerDblClick(Sender: TObject);
begin
  PushEvent(CreateMouseEvent(nil, MOUSE_DBL_CLICK, mbLeft, TWinControl(Sender).ScreenToClient(Controls.Mouse.CursorPos), Controls.Mouse.CursorPos));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
  PushEvent(CreateMouseWheelEvent(nil, TWinControl(Sender), WheelDelta, MousePos));
  Handled := false;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  PushEvent(CreateKeyEvent(nil, KEY_DOWN, Key));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  PushEvent(CreateKeyEvent(nil, KEY_UP, Key));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerResize(Sender: TObject);
begin
  PushEvent(CreateWindowEvent(nil, WINDOW_RESIZE, TControl(Sender)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerActivate(Sender: TObject);
begin
  PushEvent(CreateWindowEvent(nil, WINDOW_ACTIVATE, TControl(Sender)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerDeactivate(Sender: TObject);
begin
  PushEvent(CreateWindowEvent(nil, WINDOW_DEACTIVATE, TControl(Sender)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.RecordEvent(const aEvent: TEvent);
var
  me: TMouseEvent;
  ke: TKeyEvent;
  we: TWindowEvent;

  function GetPressedButtons: TMouseButtons;
  begin
    result := [];
    if (GetKeyState(VK_LBUTTON) < 0) then
      result := result + [mbLeft];
    if (GetKeyState(VK_RBUTTON) < 0) then
      result := result + [mbRight];
    if (GetKeyState(VK_MBUTTON) < 0) then
      result := result + [mbMiddle];
    if (GetKeyState(VK_XBUTTON1) < 0) then
      result := result + [mbExtra1];
    if (GetKeyState(VK_XBUTTON2) < 0) then
      result := result + [mbExtra2];
  end;

begin
  inherited RecordEvent(aEvent);

  if Supports(aEvent, TMouseEvent, me) then begin
    fMouse.ClientPos := me.ClientPos;
    fMouse.ScreenPos := me.ScreenPos;
    case me.EventType of
      MOUSE_DOWN:
        Include(fMouse.Buttons, me.Button);
      MOUSE_UP:
        Exclude(fMouse.Buttons, me.Button);
      MOUSE_LEAVE:
        fMouse.Buttons := [];
      MOUSE_ENTER:
        fMouse.Buttons := GetPressedButtons;
    end;

  end else if Supports(aEvent, TKeyEvent, ke) then begin
    case ke.EventType of
      KEY_DOWN,
      KEY_REPEAT: begin
        fKeyboard.KeyState[ke.KeyCode and $FF] := true;
        case ke.KeyCode of
          VK_SHIFT:   Include(fKeyboard.Modifiers, ssShift);
          VK_MENU:    Include(fKeyboard.Modifiers, ssAlt);
          VK_CONTROL: Include(fKeyboard.Modifiers, ssCtrl);
        end;
      end;
      KEY_UP: begin
        fKeyboard.KeyState[ke.KeyCode and $FF] := false;
        case ke.KeyCode of
          VK_SHIFT:   Exclude(fKeyboard.Modifiers, ssShift);
          VK_MENU:    Exclude(fKeyboard.Modifiers, ssAlt);
          VK_CONTROL: Exclude(fKeyboard.Modifiers, ssCtrl);
        end;
      end;
    end;
    if ([ssCtrl, ssAlt] - fKeyboard.Modifiers = [])
      then include(fKeyboard.Modifiers, ssAltGr)
      else exclude(fKeyboard.Modifiers, ssAltGr);

  end else if Supports(aEvent, TWindowEvent, we) then begin
    case we.EventType of
      WINDOW_ACTIVATE:
        fWindow.Active := true;
      WINDOW_DEACTIVATE:
        fWindow.Active := false;
      WINDOW_RESIZE: begin
        fWindow.ScreenRect   := we.ScreenRect;
        fWindow.ClientWidth  := we.ClientWidth;
        fWindow.ClientHeight := we.ClientHeight;
      end;
    end;
  end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateMouseEvent(aEvent: TMouseEvent; aType: TEventType; aButton: TMouseButton; aClientPos, aScreenPos: TPoint): TMouseEvent;
begin
  result := aEvent;
  if not Assigned(result) then
    result := TMouseEvent.Create;
  result.EventType := aType;
  result.Button    := aButton;
  result.ClientPos := aClientPos;
  result.ScreenPos := aScreenPos;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateMouseWheelEvent(aEvent: TMouseWheelEvent; aSender: TWinControl; aDelta: Integer; aClientPos: TPoint): TMouseWheelEvent;
begin
  result := aEvent;
  if not Assigned(result) then
    result := TMouseWheelEvent.Create;
  result.ClientPos  := aClientPos;
  result.ScreenPos  := aSender.ClientToScreen(aClientPos);
  result.WheelDelta := aDelta;
  if (aDelta < 0)
     then result.EventType := MOUSE_WHEEL_DOWN
     else result.EventType := MOUSE_WHEEL_UP;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateKeyEvent(aEvent: TKeyEvent; aType: TEventType; aKey: Word): TKeyEvent;
begin
  result := aEvent;
  if not Assigned(result) then
    result := TKeyEvent.Create;
  result.EventType := aType;
  if (aType = KEY_DOWN) and fKeyboard.KeyState[aKey and $FF] then
    result.EventType := KEY_REPEAT;
  result.KeyCode  := aKey;
  result.CharCode := VKCodeToCharCode(aKey, fKeyboard.Modifiers);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateWindowEvent(aEvent: TWindowEvent; aType: TEventType; aSender: TControl): TWindowEvent;
var
  p: TPoint;
begin
  p := aSender.ScreenToClient(Point(0, 0));
  result := aEvent;
  if not Assigned(result) then
    result := TWindowEvent.Create;
  result.EventType    := aType;
  result.ClientWidth  := aSender.ClientWidth;
  result.ClientHeight := aSender.ClientHeight;
  result.ScreenRect   := Rect(p.x, p.y, p.x + result.ClientWidth, p.y + result.ClientHeight);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.AttachEvents(const aControl: TWinControl; const aMask: TEventTypeMask);
var
  ctl: TWinControlVisibilityClass;
  frm: TCustomFormVisibilityClass;
begin
  ctl := TWinControlVisibilityClass(aControl);

  // mouse events
  if MaskHasType(aMask, MOUSE_DOWN)      then ctl.OnMouseDown  := @HandlerMouseDown;
  if MaskHasType(aMask, MOUSE_UP)        then ctl.OnMouseUp    := @HandlerMouseUp;
  if MaskHasType(aMask, MOUSE_MOVE)      then ctl.OnMouseMove  := @HandlerMouseMove;
  if MaskHasType(aMask, MOUSE_ENTER)     then ctl.OnMouseEnter := @HandlerMouseEnter;
  if MaskHasType(aMask, MOUSE_LEAVE)     then ctl.OnMouseLeave := @HandlerMouseLeave;
  if MaskHasType(aMask, MOUSE_CLICK)     then ctl.OnClick      := @HandlerClick;
  if MaskHasType(aMask, MOUSE_DBL_CLICK) then ctl.OnDblClick   := @HandlerDblClick;
  if MaskHasType(aMask, MOUSE_WHEEL_DOWN) or
     MaskHasType(aMask, MOUSE_WHEEL_UP)  then ctl.OnMouseWheel := @HandlerMouseWheel;

  // key events
  if MaskHasType(aMask, KEY_DOWN) then ctl.OnKeyDown := @HandlerKeyDown;
  if MaskHasType(aMask, KEY_UP)   then ctl.OnKeyUp   := @HandlerKeyUp;

  // window events
  if MaskHasType(aMask, WINDOW_RESIZE) then begin
    ctl.OnResize := @HandlerResize;
    fWindow.ClientWidth  := ctl.ClientWidth;
    fWindow.ClientHeight := ctl.ClientHeight;
  end;
  if (aControl is TCustomForm) then begin
    frm := TCustomFormVisibilityClass(aControl);
    frm.KeyPreview := true;
    if MaskHasType(aMask, WINDOW_ACTIVATE)   then frm.OnActivate   := @HandlerActivate;
    if MaskHasType(aMask, WINDOW_DEACTIVATE) then frm.OnDeactivate := @HandlerDeactivate;
  end;
end;

end.