MycLib/AuraTrader/DynamicFMXControl.pas

unit DynamicFMXControl;

interface

uses
    System.SysUtils,
    System.Types,
    System.UITypes,
    System.Classes,
    FMX.Controls,
    FMX.Graphics,
    FMX.Forms,
    FMX.StdCtrls,
    FMX.Types;

type
    // Dezidierte Event-Typen für virtuelle Methoden von TControl
    TControlPaintEvent = reference to procedure;
    TControlMouseEvent = reference to procedure(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    TControlMouseMoveEvent = reference to procedure(Shift: TShiftState; X, Y: Single);
    TControlMouseWheelEvent = reference to procedure(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean);
    TControlKeyEvent = reference to procedure(var Key: Word; var KeyChar: WideChar; Shift: TShiftState);
    TControlDragEvent = reference to procedure(const Data: TDragObject; const Point: TPointF);
    TControlDragOverEvent = reference to procedure(const Data: TDragObject; const Point: TPointF; var Operation: TDragOperation);
    TControlNotifyEvent = reference to procedure;
    TControlCanFocusEvent = reference to function: Boolean;
    TControlShowContextMenuEvent = reference to function(const ScreenPosition: TPointF): Boolean;
    TControlSetHintEvent = reference to procedure(const AHint: string);
    TControlGetHintStringEvent = reference to function: string;
    TControlHasHintEvent = reference to function: Boolean;
    TControlCanShowHintEvent = reference to function: Boolean;
    TControlGetDefaultSizeEvent = reference to function: TSizeF;
    TControlSetVisibleEvent = reference to procedure(const Value: Boolean);
    TControlSetEnabledEvent = reference to procedure(const Value: Boolean);
    TControlDoAbsoluteChangedEvent = reference to procedure;

    TDynamicControl = class(TControl)
    private
        // Private Felder für die Event-Handler
        FPaintEvent: TControlPaintEvent;
        FMouseDownEvent: TControlMouseEvent;
        FMouseUpEvent: TControlMouseEvent;
        FMouseMoveEvent: TControlMouseMoveEvent;
        FMouseWheelEvent: TControlMouseWheelEvent;
        FKeyDownEvent: TControlKeyEvent;
        FKeyUpEvent: TControlKeyEvent;
        FClickEvent: TControlNotifyEvent;
        FDblClickEvent: TControlNotifyEvent;
        FDragEnterEvent: TControlDragEvent;
        FDragOverEvent: TControlDragOverEvent;
        FDragDropEvent: TControlDragEvent;
        FDragLeaveEvent: TControlNotifyEvent;
        FDragEndEvent: TControlNotifyEvent;
        FEnterEvent: TControlNotifyEvent;
        FExitEvent: TControlNotifyEvent;
        FMouseEnterEvent: TControlNotifyEvent;
        FMouseLeaveEvent: TControlNotifyEvent;
        FResizeEvent: TControlNotifyEvent;
        FResizedEvent: TControlNotifyEvent;
        FCanFocusEvent: TControlCanFocusEvent;
        FShowContextMenuEvent: TControlShowContextMenuEvent;
        FSetHintEvent: TControlSetHintEvent;
        FGetHintStringEvent: TControlGetHintStringEvent;
        FHasHintEvent: TControlHasHintEvent;
        FCanShowHintEvent: TControlCanShowHintEvent;
        FGetDefaultSizeEvent: TControlGetDefaultSizeEvent;
        FRecalculateAbsoluteMatricesEvent: TControlNotifyEvent;
        FSetVisibleEvent: TControlSetVisibleEvent;
        FSetEnabledEvent: TControlSetEnabledEvent;
        FDoAbsoluteChangedEvent: TControlDoAbsoluteChangedEvent;

    protected
        // Überschriebene virtuelle Methoden, die die Events auslösen
        procedure Paint; override;
        procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
        procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
        procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
        procedure MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean); override;
        procedure Click; override;
        procedure DblClick; override;
        procedure KeyDown(var Key: Word; var KeyChar: WideChar; Shift: TShiftState); override;
        procedure KeyUp(var Key: Word; var KeyChar: WideChar; Shift: TShiftState); override;
        procedure DragEnter(const Data: TDragObject; const Point: TPointF); override;
        procedure DragOver(const Data: TDragObject; const Point: TPointF; var Operation: TDragOperation); override;
        procedure DragDrop(const Data: TDragObject; const Point: TPointF); override;
        procedure DragLeave; override;
        procedure DragEnd; override;
        procedure DoEnter; override;
        procedure DoExit; override;
        procedure DoMouseEnter; override;
        procedure DoMouseLeave; override;
        procedure Resize; override;
        procedure DoResized; override;
        function GetCanFocus: Boolean; override;
        function ShowContextMenu(const ScreenPosition: TPointF): Boolean; override;
        procedure SetHint(const AHint: string); override;
        function GetHintString: string; override;
        function HasHint: Boolean; override;
        function CanShowHint: Boolean; override;
        function GetDefaultSize: TSizeF; override;
        procedure RecalculateAbsoluteMatrices; override;
        procedure SetVisible(const Value: Boolean); override;
        procedure SetEnabled(const Value: Boolean); override;
        procedure DoAbsoluteChanged; override;

    public
        constructor Create(AOwner: TComponent); override;

        // Public Properties, die die Events exponieren
        property OnPaint: TControlPaintEvent read FPaintEvent write FPaintEvent;
        property OnMouseDown: TControlMouseEvent read FMouseDownEvent write FMouseDownEvent;
        property OnMouseUp: TControlMouseEvent read FMouseUpEvent write FMouseUpEvent;
        property OnMouseMove: TControlMouseMoveEvent read FMouseMoveEvent write FMouseMoveEvent;
        property OnMouseWheel: TControlMouseWheelEvent read FMouseWheelEvent write FMouseWheelEvent;
        property OnClick: TControlNotifyEvent read FClickEvent write FClickEvent;
        property OnDblClick: TControlNotifyEvent read FDblClickEvent write FDblClickEvent;
        property OnKeyDown: TControlKeyEvent read FKeyDownEvent write FKeyDownEvent;
        property OnKeyUp: TControlKeyEvent read FKeyUpEvent write FKeyUpEvent;
        property OnDragEnter: TControlDragEvent read FDragEnterEvent write FDragEnterEvent;
        property OnDragOver: TControlDragOverEvent read FDragOverEvent write FDragOverEvent;
        property OnDragDrop: TControlDragEvent read FDragDropEvent write FDragDropEvent;
        property OnDragLeave: TControlNotifyEvent read FDragLeaveEvent write FDragLeaveEvent;
        property OnDragEnd: TControlNotifyEvent read FDragEndEvent write FDragEndEvent;
        property OnEnter: TControlNotifyEvent read FEnterEvent write FEnterEvent;
        property OnExit: TControlNotifyEvent read FExitEvent write FExitEvent;
        property OnMouseEnter: TControlNotifyEvent read FMouseEnterEvent write FMouseEnterEvent;
        property OnMouseLeave: TControlNotifyEvent read FMouseLeaveEvent write FMouseLeaveEvent;
        property OnResize: TControlNotifyEvent read FResizeEvent write FResizeEvent;
        property OnResized: TControlNotifyEvent read FResizedEvent write FResizedEvent;
        property OnCanFocus: TControlCanFocusEvent read FCanFocusEvent write FCanFocusEvent;
        property OnShowContextMenu: TControlShowContextMenuEvent read FShowContextMenuEvent write FShowContextMenuEvent;
        property OnSetHint: TControlSetHintEvent read FSetHintEvent write FSetHintEvent;
        property OnGetHintString: TControlGetHintStringEvent read FGetHintStringEvent write FGetHintStringEvent;
        property OnHasHint: TControlHasHintEvent read FHasHintEvent write FHasHintEvent;
        property OnCanShowHint: TControlCanShowHintEvent read FCanShowHintEvent write FCanShowHintEvent;
        property OnGetDefaultSize: TControlGetDefaultSizeEvent read FGetDefaultSizeEvent write FGetDefaultSizeEvent;
        property OnRecalculateAbsoluteMatrices: TControlNotifyEvent
            read FRecalculateAbsoluteMatricesEvent write FRecalculateAbsoluteMatricesEvent;
        property OnSetVisible: TControlSetVisibleEvent read FSetVisibleEvent write FSetVisibleEvent;
        property OnSetEnabled: TControlSetEnabledEvent read FSetEnabledEvent write FSetEnabledEvent;
        property OnDoAbsoluteChanged: TControlDoAbsoluteChangedEvent read FDoAbsoluteChangedEvent write FDoAbsoluteChangedEvent;
    end;

implementation

{ TDynamicControl }

constructor TDynamicControl.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);
    Width := 150;
    Height := 100;
    HitTest := True;
end;

function TDynamicControl.CanShowHint: Boolean;
begin
    if Assigned(FCanShowHintEvent) then
        Result := FCanShowHintEvent
    else
        Result := inherited CanShowHint;
end;

procedure TDynamicControl.Click;
begin
    inherited Click;
    if Assigned(FClickEvent) then
        FClickEvent;
end;

procedure TDynamicControl.DblClick;
begin
    inherited DblClick;
    if Assigned(FDblClickEvent) then
        FDblClickEvent;
end;

procedure TDynamicControl.DoAbsoluteChanged;
begin
    inherited DoAbsoluteChanged;
    if Assigned(FDoAbsoluteChangedEvent) then
        FDoAbsoluteChangedEvent;
end;

procedure TDynamicControl.DragDrop(const Data: TDragObject; const Point: TPointF);
begin
    inherited DragDrop(Data, Point);
    if Assigned(FDragDropEvent) then
        FDragDropEvent(Data, Point);
end;

procedure TDynamicControl.DragEnd;
begin
    inherited DragEnd;
    if Assigned(FDragEndEvent) then
        FDragEndEvent;
end;

procedure TDynamicControl.DragEnter(const Data: TDragObject; const Point: TPointF);
begin
    inherited DragEnter(Data, Point);
    if Assigned(FDragEnterEvent) then
        FDragEnterEvent(Data, Point);
end;

procedure TDynamicControl.DragLeave;
begin
    inherited DragLeave;
    if Assigned(FDragLeaveEvent) then
        FDragLeaveEvent;
end;

procedure TDynamicControl.DragOver(const Data: TDragObject; const Point: TPointF; var Operation: TDragOperation);
begin
    inherited DragOver(Data, Point, Operation);
    if Assigned(FDragOverEvent) then
        FDragOverEvent(Data, Point, Operation);
end;

procedure TDynamicControl.DoEnter;
begin
    inherited DoEnter;
    if Assigned(FEnterEvent) then
        FEnterEvent;
end;

procedure TDynamicControl.DoExit;
begin
    inherited DoExit;
    if Assigned(FExitEvent) then
        FExitEvent;
end;

procedure TDynamicControl.DoMouseEnter;
begin
    inherited DoMouseEnter;
    if Assigned(FMouseEnterEvent) then
        FMouseEnterEvent;
end;

procedure TDynamicControl.DoMouseLeave;
begin
    inherited DoMouseLeave;
    if Assigned(FMouseLeaveEvent) then
        FMouseLeaveEvent;
end;

procedure TDynamicControl.DoResized;
begin
    inherited DoResized;
    if Assigned(FResizedEvent) then
        FResizedEvent;
end;

function TDynamicControl.GetCanFocus: Boolean;
begin
    if Assigned(FCanFocusEvent) then
        Result := FCanFocusEvent
    else
        Result := inherited GetCanFocus;
end;

function TDynamicControl.GetDefaultSize: TSizeF;
begin
    if Assigned(FGetDefaultSizeEvent) then
        Result := FGetDefaultSizeEvent
    else
        Result := inherited GetDefaultSize;
end;

function TDynamicControl.GetHintString: string;
begin
    if Assigned(FGetHintStringEvent) then
        Result := FGetHintStringEvent
    else
        Result := inherited GetHintString;
end;

function TDynamicControl.HasHint: Boolean;
begin
    if Assigned(FHasHintEvent) then
        Result := FHasHintEvent
    else
        Result := inherited HasHint;
end;

procedure TDynamicControl.KeyDown(var Key: Word; var KeyChar: WideChar; Shift: TShiftState);
begin
    inherited KeyDown(Key, KeyChar, Shift);
    if Assigned(FKeyDownEvent) then
        FKeyDownEvent(Key, KeyChar, Shift);
end;

procedure TDynamicControl.KeyUp(var Key: Word; var KeyChar: WideChar; Shift: TShiftState);
begin
    inherited KeyUp(Key, KeyChar, Shift);
    if Assigned(FKeyUpEvent) then
        FKeyUpEvent(Key, KeyChar, Shift);
end;

procedure TDynamicControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
    inherited MouseDown(Button, Shift, X, Y);
    if Assigned(FMouseDownEvent) then
        FMouseDownEvent(Button, Shift, X, Y);
end;

procedure TDynamicControl.MouseMove(Shift: TShiftState; X, Y: Single);
begin
    inherited MouseMove(Shift, X, Y);
    if Assigned(FMouseMoveEvent) then
        FMouseMoveEvent(Shift, X, Y);
end;

procedure TDynamicControl.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
    inherited MouseUp(Button, Shift, X, Y);
    if Assigned(FMouseUpEvent) then
        FMouseUpEvent(Button, Shift, X, Y);
end;

procedure TDynamicControl.MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean);
begin
    inherited MouseWheel(Shift, WheelDelta, Handled);
    if Assigned(FMouseWheelEvent) then
        FMouseWheelEvent(Shift, WheelDelta, Handled);
end;

procedure TDynamicControl.Paint;
begin
    inherited Paint;
    if Assigned(FPaintEvent) then
        FPaintEvent
    else
    begin
        Canvas.Fill.Color := TAlphaColors.LightSteelBlue;
        Canvas.FillRect(LocalRect, 0, 0, [], 1);
        Canvas.Stroke.Color := TAlphaColors.Gray;
        Canvas.Stroke.Thickness := 1;
        Canvas.DrawRect(LocalRect, 0, 0, [], 1);
    end;
end;

procedure TDynamicControl.RecalculateAbsoluteMatrices;
begin
    inherited RecalculateAbsoluteMatrices;
    if Assigned(FRecalculateAbsoluteMatricesEvent) then
        FRecalculateAbsoluteMatricesEvent;
end;

procedure TDynamicControl.Resize;
begin
    inherited Resize;
    if Assigned(FResizeEvent) then
        FResizeEvent;
end;

procedure TDynamicControl.SetEnabled(const Value: Boolean);
begin
    inherited SetEnabled(Value);
    if Assigned(FSetEnabledEvent) then
        FSetEnabledEvent(Value);
end;

procedure TDynamicControl.SetHint(const AHint: string);
begin
    inherited SetHint(AHint);
    if Assigned(FSetHintEvent) then
        FSetHintEvent(AHint);
end;

procedure TDynamicControl.SetVisible(const Value: Boolean);
begin
    inherited SetVisible(Value);
    if Assigned(FSetVisibleEvent) then
        FSetVisibleEvent(Value);
end;

function TDynamicControl.ShowContextMenu(const ScreenPosition: TPointF): Boolean;
begin
    if Assigned(FShowContextMenuEvent) then
        Result := FShowContextMenuEvent(ScreenPosition)
    else
        Result := inherited ShowContextMenu(ScreenPosition);
end;

end.