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, uutlCommon; type ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// TutlEventType = byte; TutlEventTypes = set of TutlEventType; TutlMouseButtons = set of TMouseButton; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// TutlWinControlEventArgs = class(TutlEventArgs) private fControl: TControl; fEventType: TutlEventType; fTimestamp: Single; public property Control: TControl read fControl; property EventType: TutlEventType read fEventType; property Timestamp: Single read fTimestamp; constructor Create( const aControl: TControl; const aEventType: TutlEventType); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// TutlMouseEventArgs = class(TutlWinControlEventArgs) 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 aControl: TControl; const aEventType: TutlEventType; const aButtons: TutlMouseButtons; const aClientPos: TPoint); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// TutlMouseWheelEventArgs = class(TutlWinControlEventArgs) 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 aControl: TControl; const aWheelDelta: Integer; const aClientPos: TPoint); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// TutlKeyEventArgs = class(TutlWinControlEventArgs) private fCharCode: WideChar; fKeyCode: Word; public property CharCode: WideChar read fCharCode; property KeyCode: Word read fKeyCode; constructor Create( const aControl: TControl; const aEventType: TutlEventType; const aCharCode: WideChar; const aKeyCode: Word); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// TutlWindowEventArgs = class(TutlWinControlEventArgs) 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 aControl: TControl; const aEventType: TutlEventType; const aScreenRect: TRect; const aClientWidth: Cardinal; const aClientHeight: Cardinal); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// TutlWinControlEventManager = class( TutlInterfacedObject , IutlObservable) 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 ]; public type TutlEventType = uutlEventManager.TutlEventType; TutlEventTypes = uutlEventManager.TutlEventTypes; TutlMouseButtons = uutlEventManager.TutlMouseButtons; TutlWinControlEventArgs = uutlEventManager.TutlWinControlEventArgs; TutlMouseEventArgs = uutlEventManager.TutlMouseEventArgs; TutlMouseWheelEventArgs = uutlEventManager.TutlMouseWheelEventArgs; TutlKeyEventArgs = uutlEventManager.TutlKeyEventArgs; TutlWindowEventArgs = uutlEventManager.TutlWindowEventArgs; 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; fEventListener: TutlEventListenerSet; 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(aEventArgs: IutlEventArgs); virtual; procedure DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs); function CreateMouseEventArgs( aControl: TControl; aType: TutlEventType; aButtons: TutlMouseButtons; aClientPos: TPoint): IutlEventArgs; virtual; function CreateMouseWheelEventArgs( aControl: TControl; aDelta: Integer; aClientPos: TPoint): IutlEventArgs; virtual; function CreateKeyEventArgs( aControl: TControl; aType: TutlEventType; aKey: Word): IutlEventArgs; virtual; function CreateWindowEventArgs( aControl: TControl; aType: TutlEventType): IutlEventArgs; virtual; public { IutlObservable } procedure RegisterEventListener (aListener: IutlEventListener); procedure UnregisterEventListener(aListener: IutlEventListener); public property Keyboard: TKeyboardState read fKeyboard; property Mouse: TMouseState read fMouse; property Window: TWindowState read fWindow; procedure AttachEvents(const aControl: TWinControl; const aTypes: TutlEventTypes); constructor Create; destructor Destroy; override; 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; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// //TutlWinControlEventArgs//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// constructor TutlWinControlEventArgs.Create(const aControl: TControl; const aEventType: TutlEventType); begin inherited Create; fControl := aControl; fEventType := aEventType; fTimestamp := GetMicroTime / 1000000; end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// //TutlMouseEventArgs///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// constructor TutlMouseEventArgs.Create( const aControl: TControl; const aEventType: TutlEventType; const aButtons: TutlMouseButtons; const aClientPos: TPoint); begin inherited Create(aControl, aEventType); fButtons := aButtons; fClientPos := aClientPos; fScreenPos := Control.ClientToScreen(fClientPos); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// //TutlMouseWheelEventArgs//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// constructor TutlMouseWheelEventArgs.Create( const aControl: TControl; const aWheelDelta: Integer; const aClientPos: TPoint); begin if (aWheelDelta < 0) then inherited Create(aControl, TutlWinControlEventManager.EVENT_MOUSE_WHEEL_DOWN) else inherited Create(aControl, TutlWinControlEventManager.EVENT_MOUSE_WHEEL_UP); fWheelDelta := aWheelDelta; fClientPos := aClientPos; fScreenPos := Control.ClientToScreen(fClientPos); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// //TutlKeyEventArgs/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// constructor TutlKeyEventArgs.Create( const aControl: TControl; const aEventType: TutlEventType; const aCharCode: WideChar; const aKeyCode: Word); begin inherited Create(aControl, aEventType); fCharCode := aCharCode; fKeyCode := aKeyCode; end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// //TutlWindowEventArgs//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// constructor TutlWindowEventArgs.Create( const aControl: TControl; const aEventType: TutlEventType; const aScreenRect: TRect; const aClientWidth: Cardinal; const aClientHeight: Cardinal); begin inherited Create(aControl, aEventType); fScreenRect := aScreenRect; fClientWidth := aClientWidth; fClientHeight := aClientHeight; end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// //TutlWinControlEventManager///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.HandlerMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin DispatchEvent(self, CreateMouseEventArgs(Sender as TControl, EVENT_MOUSE_DOWN, [Button], Point(X, Y))); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.HandlerMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin DispatchEvent(self, CreateMouseEventArgs(Sender as TControl, EVENT_MOUSE_UP, [Button], Point(X, Y))); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.HandlerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin DispatchEvent(self, CreateMouseEventArgs(Sender as TControl, EVENT_MOUSE_MOVE, [], Point(X, Y))); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.HandlerMouseEnter(Sender: TObject); begin DispatchEvent(self, CreateMouseEventArgs(Sender as TControl, EVENT_MOUSE_ENTER, [], TControl(Sender).ScreenToClient(Controls.Mouse.CursorPos))); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.HandlerMouseLeave(Sender: TObject); begin DispatchEvent(self, CreateMouseEventArgs(Sender as TControl, EVENT_MOUSE_LEAVE, [], TControl(Sender).ScreenToClient(Controls.Mouse.CursorPos))); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.HandlerClick(Sender: TObject); begin DispatchEvent(self, CreateMouseEventArgs(Sender as TControl, EVENT_MOUSE_CLICK, [], TControl(Sender).ScreenToClient(Controls.Mouse.CursorPos))); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.HandlerDblClick(Sender: TObject); begin DispatchEvent(self, CreateMouseEventArgs(Sender as TControl, 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(self, CreateMouseWheelEventArgs(Sender as TControl, WheelDelta, MousePos)); Handled := false; end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.HandlerKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin DispatchEvent(self, CreateKeyEventArgs(Sender as TControl, EVENT_KEY_DOWN, Key)); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.HandlerKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); begin DispatchEvent(self, CreateKeyEventArgs(Sender as TControl, EVENT_KEY_UP, Key)); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.HandlerResize(Sender: TObject); begin DispatchEvent(self, CreateWindowEventArgs(Sender as TControl, EVENT_WINDOW_RESIZE)); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.HandlerActivate(Sender: TObject); begin DispatchEvent(self, CreateWindowEventArgs(Sender as TControl, EVENT_WINDOW_ACTIVATE)); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.HandlerDeactivate(Sender: TObject); begin DispatchEvent(self, CreateWindowEventArgs(Sender as TControl, EVENT_WINDOW_DEACTIVATE)); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.RecordEvent(aEventArgs: IutlEventArgs); var mea: TutlMouseEventArgs; kea: TutlKeyEventArgs; wea: TutlWindowEventArgs; 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(aEventArgs, TutlMouseEventArgs, mea) then begin fMouse.ClientPos := mea.ClientPos; fMouse.ScreenPos := mea.ScreenPos; case mea.EventType of EVENT_MOUSE_DOWN: fMouse.Buttons := fMouse.Buttons + mea.Buttons; EVENT_MOUSE_UP: fMouse.Buttons := fMouse.Buttons - mea.Buttons; EVENT_MOUSE_LEAVE: fMouse.Buttons := []; EVENT_MOUSE_ENTER: fMouse.Buttons := GetPressedButtons; end; end else if Supports(aEventArgs, TutlKeyEventArgs, kea) then begin case kea.EventType of EVENT_KEY_DOWN, EVENT_KEY_REPEAT: begin fKeyboard.KeyState[kea.KeyCode and $FF] := true; case kea.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[kea.KeyCode and $FF] := false; case kea.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(aEventArgs, TutlWindowEventArgs, wea) then begin case wea.EventType of EVENT_WINDOW_ACTIVATE: fWindow.Active := true; EVENT_WINDOW_DEACTIVATE: fWindow.Active := false; EVENT_WINDOW_RESIZE: begin fWindow.ScreenRect := wea.ScreenRect; fWindow.ClientWidth := wea.ClientWidth; fWindow.ClientHeight := wea.ClientHeight; end; end; end; end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs); begin RecordEvent(aEventArgs); fEventListener.DispatchEvent(aSender, aEventArgs); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// function TutlWinControlEventManager.CreateMouseEventArgs( aControl: TControl; aType: TutlEventType; aButtons: TutlMouseButtons; aClientPos: TPoint): IutlEventArgs; begin result := TutlMouseEventArgs.Create( aControl, aType, aButtons, aClientPos); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// function TutlWinControlEventManager.CreateMouseWheelEventArgs( aControl: TControl; aDelta: Integer; aClientPos: TPoint): IutlEventArgs; begin result := TutlMouseWheelEventArgs.Create( aControl, aDelta, aClientPos); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// function TutlWinControlEventManager.CreateKeyEventArgs( aControl: TControl; aType: TutlEventType; aKey: Word): IutlEventArgs; begin if (aType = EVENT_KEY_DOWN) and fKeyboard.KeyState[aKey and $FF] then aType := EVENT_KEY_REPEAT; result := TutlKeyEventArgs.Create( aControl, aType, VKCodeToCharCode(aKey, fKeyboard.Modifiers), aKey); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// function TutlWinControlEventManager.CreateWindowEventArgs( aControl: TControl; aType: TutlEventType): IutlEventArgs; var p0, p1: TPoint; begin with aControl do begin p0 := ClientToScreen(Point(0, 0)); p1 := ClientToScreen(Point(Width, Height)); end; result := TutlWindowEventArgs.Create( aControl, aType, Rect(p0.x, p0.y, p1.x, p1.y), (aControl as TWinControl).ClientWidth, (aControl as TWinControl).ClientHeight); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.RegisterEventListener(aListener: IutlEventListener); begin if Assigned(fEventListener) then fEventListener.Add(aListener); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TutlWinControlEventManager.UnregisterEventListener(aListener: IutlEventListener); begin if Assigned(fEventListener) then fEventListener.Remove(aListener); 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; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// constructor TutlWinControlEventManager.Create; begin inherited Create; fEventListener := TutlEventListenerSet.Create; end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// destructor TutlWinControlEventManager.Destroy; begin FreeAndNil(fEventListener); inherited Destroy; end; end.