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, Controls,
  uutlEvent;

type
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlMouseButtons = set of TMouseButton;
  TutlWinControlEvent = class(TutlEvent)
  private
    function GetControl: TControl;

  public
    property Control: TControl read GetControl;
    constructor Create(
      const aSender: TControl;
      const aEventType: TutlEventType);
  end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlMouseEvent = class(TutlWinControlEvent)
  private
    fButtons: TutlMouseButtons;
    fClientPos: TPoint;
    fScreenPos: TPoint;

  public
    property Buttons:   TutlMouseButtons read fButtons;
    property ClientPos: TPoint           read fClientPos;
    property ScreenPos: TPoint           read fScreenPos;

    constructor Create(
      const aSender: TControl;
      const aEventType: TutlEventType;
      const aButtons: TutlMouseButtons;
      const aClientPos: TPoint);
  end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlMouseWheelEvent = class(TutlWinControlEvent)
  private
    fWheelDelta: Integer;
    fClientPos: TPoint;
    fScreenPos: TPoint;

  public
    property WheelDelta: Integer read fWheelDelta;
    property ClientPos:  TPoint  read fClientPos;
    property ScreenPos:  TPoint  read fScreenPos;

    constructor Create(
      const aSender: TControl;
      const aWheelDelta: Integer;
      const aClientPos: TPoint);
  end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlKeyEvent = class(TutlWinControlEvent)
  private
    fCharCode: WideChar;
    fKeyCode: Word;

  public
    property CharCode: WideChar read fCharCode;
    property KeyCode:  Word     read fKeyCode;

    constructor Create(
      const aSender: TControl;
      const aEventType: TutlEventType;
      const aCharCode: WideChar;
      const aKeyCode: Word);
  end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlWindowEvent = class(TutlWinControlEvent)
  private
    fScreenRect: TRect;
    fClientWidth: Cardinal;
    fClientHeight: Cardinal;

  public
    property ScreenRect:   TRect    read fScreenRect;
    property ClientWidth:  Cardinal read fClientWidth;
    property ClientHeight: Cardinal read fClientHeight;

    constructor Create(
      const aSender: TControl;
      const aEventType: TutlEventType;
      const aScreenRect: TRect;
      const aClientWidth: Cardinal;
      const aClientHeight: Cardinal);
  end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlWinControlEventManager = class(TutlEventListenerSet)
  public const
    EVENT_MOUSE_DOWN        =  0;
    EVENT_MOUSE_UP          =  1;
    EVENT_MOUSE_WHEEL_UP    =  2;
    EVENT_MOUSE_WHEEL_DOWN  =  3;
    EVENT_MOUSE_MOVE        =  4;
    EVENT_MOUSE_ENTER       =  5;
    EVENT_MOUSE_LEAVE       =  6;
    EVENT_MOUSE_CLICK       =  7;
    EVENT_MOUSE_DBL_CLICK   =  8;

    EVENT_KEY_DOWN          = 10;
    EVENT_KEY_REPEAT        = 11;
    EVENT_KEY_UP            = 12;

    EVENT_WINDOW_RESIZE     = 15;
    EVENT_WINDOW_ACTIVATE   = 16;
    EVENT_WINDOW_DEACTIVATE = 17;

    EVENTS_MOUSE: TutlEventTypes = [
      EVENT_MOUSE_DOWN,
      EVENT_MOUSE_UP,
      EVENT_MOUSE_WHEEL_UP,
      EVENT_MOUSE_WHEEL_DOWN,
      EVENT_MOUSE_MOVE,
      EVENT_MOUSE_ENTER,
      EVENT_MOUSE_LEAVE,
      EVENT_MOUSE_CLICK,
      EVENT_MOUSE_DBL_CLICK
    ];
    EVENTS_KEYBOARD: TutlEventTypes = [
      EVENT_KEY_DOWN,
      EVENT_KEY_REPEAT,
      EVENT_KEY_UP
    ];
    EVENTS_WINDOW: TutlEventTypes = [
      EVENT_WINDOW_RESIZE,
      EVENT_WINDOW_ACTIVATE,
      EVENT_WINDOW_DEACTIVATE
    ];

  private type
    TKeyboardState = record
      Modifiers: TShiftState;
      KeyState: array[Byte] of Boolean;
    end;

    TMouseState = record
      ScreenPos: TPoint;
      ClientPos: TPoint;
      Buttons: TutlMouseButtons;
    end;

    TWindowState = record
      Active: Boolean;
      ScreenRect: TRect;
      ClientWidth: Integer;
      ClientHeight: Integer;
    end;
  private
    fKeyboard: TKeyboardState;
    fMouse: TMouseState;
    fWindow: TWindowState;

    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: IutlEvent); virtual;

    function CreateMouseEvent(
      aSender: TObject;
      aType: TutlEventType;
      aButtons: TutlMouseButtons;
      aClientPos: TPoint): TutlMouseEvent; virtual;

    function CreateMouseWheelEvent(
      aSender: TObject;
      aDelta: Integer;
      aClientPos: TPoint): TutlMouseWheelEvent; virtual;

    function CreateKeyEvent(
      aSender: TObject; aType: TutlEventType;
      aKey: Word): TutlKeyEvent; virtual;

    function CreateWindowEvent(
      aSender: TObject;
      aType: TutlEventType): TutlWindowEvent; virtual;

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

    procedure DispatchEvent(aEvent: IutlEvent); override;
    procedure AttachEvents(const aControl: TWinControl; const aTypes: TutlEventTypes);
  end;

implementation

uses
  LCLIntf, Forms,
  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;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWinControlEvent////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEvent.GetControl: TControl;
begin
  result := (Sender as TControl);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlWinControlEvent.Create(
  const aSender: TControl;
  const aEventType: TutlEventType);
begin
  inherited Create(aSender, aEventType);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlMouseEvent/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlMouseEvent.Create(
  const aSender: TControl;
  const aEventType: TutlEventType;
  const aButtons: TutlMouseButtons;
  const aClientPos: TPoint);
begin
  inherited Create(aSender, aEventType);
  fButtons   := aButtons;
  fClientPos := aClientPos;
  fScreenPos := Control.ClientToScreen(fClientPos);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlMouseWheelEvent////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlMouseWheelEvent.Create(
  const aSender: TControl;
  const aWheelDelta: Integer;
  const aClientPos: TPoint);
begin
  if (aWheelDelta < 0)
    then inherited Create(aSender, TutlWinControlEventManager.EVENT_MOUSE_WHEEL_DOWN)
    else inherited Create(aSender, TutlWinControlEventManager.EVENT_MOUSE_WHEEL_UP);
  fWheelDelta := aWheelDelta;
  fClientPos  := aClientPos;
  fScreenPos  := Control.ClientToScreen(fClientPos);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlKeyEvent///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlKeyEvent.Create(
  const aSender: TControl;
  const aEventType: TutlEventType;
  const aCharCode: WideChar;
  const aKeyCode: Word);
begin
  inherited Create(aSender, aEventType);
  fCharCode := aCharCode;
  fKeyCode  := aKeyCode;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWindowEvent////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlWindowEvent.Create(
  const aSender: TControl;
  const aEventType: TutlEventType;
  const aScreenRect: TRect;
  const aClientWidth: Cardinal;
  const aClientHeight: Cardinal);
begin
  inherited Create(aSender, aEventType);
  fScreenRect   := aScreenRect;
  fClientWidth  := aClientWidth;
  fClientHeight := aClientHeight;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWinControlEventManager/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_DOWN, [ Button ], Point(X, Y)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_UP, [Button], Point(X, Y)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_MOVE, [], Point(X, Y)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseEnter(Sender: TObject);
begin
  DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_ENTER, [], TControl(Sender).ScreenToClient(Controls.Mouse.CursorPos)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseLeave(Sender: TObject);
begin
  DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_LEAVE, [], TControl(Sender).ScreenToClient(Controls.Mouse.CursorPos)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerClick(Sender: TObject);
begin
  DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_CLICK, [], TControl(Sender).ScreenToClient(Controls.Mouse.CursorPos)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerDblClick(Sender: TObject);
begin
  DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_DBL_CLICK, [], TControl(Sender).ScreenToClient(Controls.Mouse.CursorPos)));
end;

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

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

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

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerResize(Sender: TObject);
begin
  DispatchEvent(CreateWindowEvent(Sender, EVENT_WINDOW_RESIZE));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerActivate(Sender: TObject);
begin
  DispatchEvent(CreateWindowEvent(Sender, EVENT_WINDOW_ACTIVATE));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerDeactivate(Sender: TObject);
begin
  DispatchEvent(CreateWindowEvent(Sender, EVENT_WINDOW_DEACTIVATE));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.RecordEvent(const aEvent: IutlEvent);
var
  me: TutlMouseEvent;
  ke: TutlKeyEvent;
  we: TutlWindowEvent;

  function GetPressedButtons: TutlMouseButtons;
  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
  if Supports(aEvent, TutlMouseEvent, me) then begin
    fMouse.ClientPos := me.ClientPos;
    fMouse.ScreenPos := me.ScreenPos;
    case me.EventType of
      EVENT_MOUSE_DOWN:
        fMouse.Buttons := fMouse.Buttons + me.Buttons;
      EVENT_MOUSE_UP:
        fMouse.Buttons := fMouse.Buttons - me.Buttons;
      EVENT_MOUSE_LEAVE:
        fMouse.Buttons := [];
      EVENT_MOUSE_ENTER:
        fMouse.Buttons := GetPressedButtons;
    end;

  end else if Supports(aEvent, TutlKeyEvent, ke) then begin
    case ke.EventType of
      EVENT_KEY_DOWN,
      EVENT_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;
      EVENT_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, TutlWindowEvent, we) then begin
    case we.EventType of
      EVENT_WINDOW_ACTIVATE:
        fWindow.Active := true;
      EVENT_WINDOW_DEACTIVATE:
        fWindow.Active := false;
      EVENT_WINDOW_RESIZE: begin
        fWindow.ScreenRect   := we.ScreenRect;
        fWindow.ClientWidth  := we.ClientWidth;
        fWindow.ClientHeight := we.ClientHeight;
      end;
    end;
  end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateMouseEvent(aSender: TObject; aType: TutlEventType;
  aButtons: TutlMouseButtons; aClientPos: TPoint): TutlMouseEvent;
begin
  result := TutlMouseEvent.Create(
    (aSender as TControl),
    aType,
    aButtons,
    aClientPos);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateMouseWheelEvent(aSender: TObject; aDelta: Integer;
  aClientPos: TPoint): TutlMouseWheelEvent;
begin
  result := TutlMouseWheelEvent.Create(
    (aSender as TControl),
    aDelta,
    aClientPos);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateKeyEvent(aSender: TObject; aType: TutlEventType; aKey: Word): TutlKeyEvent;
begin
  if (aType = EVENT_KEY_DOWN) and fKeyboard.KeyState[aKey and $FF] then
    aType := EVENT_KEY_REPEAT;
  result := TutlKeyEvent.Create(
    (aSender as TControl),
    aType,
    VKCodeToCharCode(aKey, fKeyboard.Modifiers),
    aKey);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateWindowEvent(aSender: TObject; aType: TutlEventType): TutlWindowEvent;
var
  p0, p1: TPoint;
begin
  with TControl(aSender) do begin
    p0 := ClientToScreen(Point(0, 0));
    p1 := ClientToScreen(Point(Width, Height));
  end;
  result := TutlWindowEvent.Create(
    (aSender as TControl),
    aType,
    Rect(p0.x, p0.y, p1.x, p1.y),
    (aSender as TWinControl).ClientWidth,
    (aSender as TWinControl).ClientHeight);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.DispatchEvent(aEvent: IutlEvent);
begin
  RecordEvent(aEvent);
  inherited DispatchEvent(aEvent);
end;

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

  // mouse events
  if (EVENT_MOUSE_DOWN       in aTypes) then ctl.OnMouseDown  := @HandlerMouseDown;
  if (EVENT_MOUSE_UP         in aTypes) then ctl.OnMouseUp    := @HandlerMouseUp;
  if (EVENT_MOUSE_MOVE       in aTypes) then ctl.OnMouseMove  := @HandlerMouseMove;
  if (EVENT_MOUSE_ENTER      in aTypes) then ctl.OnMouseEnter := @HandlerMouseEnter;
  if (EVENT_MOUSE_LEAVE      in aTypes) then ctl.OnMouseLeave := @HandlerMouseLeave;
  if (EVENT_MOUSE_CLICK      in aTypes) then ctl.OnClick      := @HandlerClick;
  if (EVENT_MOUSE_DBL_CLICK  in aTypes) then ctl.OnDblClick   := @HandlerDblClick;
  if (EVENT_MOUSE_WHEEL_DOWN in aTypes) or
     (EVENT_MOUSE_WHEEL_UP   in aTypes) then ctl.OnMouseWheel := @HandlerMouseWheel;

  // key events
  if (EVENT_KEY_DOWN in aTypes) then ctl.OnKeyDown := @HandlerKeyDown;
  if (EVENT_KEY_UP   in aTypes) then ctl.OnKeyUp   := @HandlerKeyUp;

  // window events
  if (EVENT_WINDOW_RESIZE in aTypes) 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 (EVENT_WINDOW_ACTIVATE   in aTypes) then frm.OnActivate   := @HandlerActivate;
    if (EVENT_WINDOW_DEACTIVATE in aTypes) then frm.OnDeactivate := @HandlerDeactivate;
  end;
end;

end.