I am quite new to Delphi and wanted to practise a little bit.
While trying to implement a basic custom component I couldn't figure out how to "catch" events like "OnMouseWheel" or "OnMouseMove" etc.. (the component just should let the user zoom into an TImage)
At the moment I wrote some public functions like LMouseWheel(...), now the user of the component has to implement the OnMouseWheel-Function, but only has to call the public MouseWheel(...)-Method to get the component working. Is there a way, that the MouseWheel-Method gets called by default?
The code is an abstract of my custom component. What do I have to do, to immediately call the LMouseWheel(...)-Method, when the user scrolls the mouse wheel over my component?
unit TLZoomage;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
{$IFDEF MSWINDOWS}
uses
Classes, SysUtils, FileUtil, Forms, LCLType, Controls, Graphics,
Dialogs, ExtCtrls, Spin, Types, Math;
type
{ TLZoomage }
TLZoomage = class(TImage)
private
{ Private-Deklarationen }
FStartZoom: integer;
FmaxZoom: integer;
FminZoom: integer;
FcurrentZoom: integer;
FzoomSpeed: integer;
mouseMoveOrigin: TPoint;
procedure setCurrentZoom(AValue: integer);
procedure setMaxZoom(AValue: integer);
procedure setMinZoom(AValue: integer);
procedure setStartZoom(AValue: integer);
protected
{ Protected-Deklarationen }
property currentZoom: integer read FcurrentZoom write setCurrentZoom;
public
{ Public-Deklarationen }
constructor Create(AOwner: TComponent); override;
//###################################################################
//###################################################################
//
// This should get called automatically
//
//###################################################################
//###################################################################
procedure LMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: integer; MousePos: TPoint; var Handled: boolean);
published
property maxZoom: integer read FmaxZoom write setMaxZoom;
property minZoom: integer read FminZoom write setMinZoom;
property startZoom: integer read FStartZoom write setStartZoom;
property zoomSpeed: integer read FzoomSpeed write FzoomSpeed;
end;
{$ENDIF}
procedure Register;
implementation
{$IFnDEF MSWINDOWS}
procedure Register;
begin
end;
{$ELSE}
procedure Register;
begin
RegisterComponents('test', [TLZoomage]);
end;
{ TLZoomage }
//###################################################################
//###################################################################
//
// This should get called automatically
//
//###################################################################
//###################################################################
procedure TLZoomage.LMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: integer; MousePos: TPoint; var Handled: boolean);
var
xZoomPoint: double;
yZoomPoint: double;
begin
if (ssCtrl in Shift) then
begin
xZoomPoint := MousePos.x / self.Width;
yZoomPoint := MousePos.y / self.Height;
// der Benutzer möchte zoomen
currentZoom := currentZoom + Sign(WheelDelta) * scrollSpeed;
self.Left := round(self.Left + MousePos.x - (xZoomPoint * self.Width));
self.Top := round(self.Top + MousePos.y - (yZoomPoint * self.Height));
end;
Handled:=true;
end;
procedure TLZoomage.setCurrentZoom(AValue: integer);
var
ChildScaleFactor: double;
ParentScaleFactor: double;
begin
FcurrentZoom := AValue;
if (FcurrentZoom < minZoom) then
FcurrentZoom := minZoom;
if (FcurrentZoom > maxZoom) then
FcurrentZoom := maxZoom;
if Assigned(self.Picture) then
begin
self.Width := round(self.Picture.Width * FcurrentZoom / 100);
self.Height := round(self.Picture.Height * FcurrentZoom / 100);
if Assigned(self.Parent) then
begin
if (self.Width < self.Parent.Width) and (self.Height < self.Parent.Height) and
(self.Height <> 0) then
begin
ChildScaleFactor := self.Width / self.Height;
ParentScaleFactor := self.Parent.Width / self.Parent.Height;
// Parent ist breiter -> Höhe gibt die größe vor
if (ParentScaleFactor > ChildScaleFactor) then
begin
self.Height := self.Parent.Height;
self.Width := round(ChildScaleFactor * self.Parent.Height);
end
else
// Parent ist höher -> Breite gibt die Größe vor
begin
self.Width := self.Parent.Width;
self.Height := round(self.Parent.Width / ChildScaleFactor);
end;
end;
end;
end;
end;
procedure TLZoomage.setMaxZoom(AValue: integer);
begin
FmaxZoom := AValue;
currentZoom := currentZoom;
end;
procedure TLZoomage.setMinZoom(AValue: integer);
begin
FminZoom := AValue;
currentZoom := currentZoom;
end;
procedure TLZoomage.setStartZoom(AValue: integer);
begin
currentZoom := AValue;
FstartZoom := currentZoom;
end;
procedure TLZoomage.limitImgPos();
begin
if Assigned(self.Parent) then
begin
// limit the Scrolling
if self.Left > 0 then
self.Left := 0;
if self.Left < -(self.Width - self.Parent.Width) then
self.Left := -(self.Width - self.Parent.Width);
if self.Top > 0 then
self.Top := 0;
if self.Top < -(self.Height - self.Parent.Height) then
self.Top := -(self.Height - self.Parent.Height);
end;
end;
constructor TLZoomage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
maxZoom := 200;
minZoom := 10;
startZoom := 100;
FzoomSpeed := 10;
currentZoom := startZoom;
end;
{$ENDIF}
end.
Solution: The simplest solution was, to override the following procedure / functions out of TControl, thanks to "Remy Lebeau":
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
Delphi's VCL TControl has virtual DoMouseWheel(Down|Up)() and Mouse(Down|Move|Up)() methods that your component can override as needed:
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; dynamic;
function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; dynamic;
function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; dynamic;
...
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); dynamic;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); dynamic;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); dynamic;
Delphi's FMX TControl has virtual Mouse(Down|Move|Up|Wheel)() methods:
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); virtual;
procedure MouseMove(Shift: TShiftState; X, Y: Single); virtual;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); virtual;
procedure MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean); virtual;
FreePascal's TControl has virtual Mouse(Down|Move|Up)() and DoMouseWheel(Down|Up)() methods that mirror VCL, as well as additional virtual DoMouseWheel(Horz|Left|Right) methods:
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); virtual;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); virtual;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); virtual;
...
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; virtual;
function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; virtual;
function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; virtual;
function DoMouseWheelHorz(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; virtual;
function DoMouseWheelLeft(Shift: TShiftState; MousePos: TPoint): Boolean; virtual;
function DoMouseWheelRight(Shift: TShiftState; MousePos: TPoint): Boolean; virtual;
In all cases, the framework handles catching the actual mouse events from the OS and then calls the per-component virtual methods automatically as needed. This works even for graphical controls, as a parent windowed control will detect mouse activity over a graphical child control and delegate accordingly.
UPDATE: in the case of Delphi's VCL TControl (not sure about Delphi's FMX TControl, or FreePascal's TControl), delegation of mouse clicks works as expected, but delegation of mouse wheel movements does not. You have to take some extra steps to receive mouse wheel notifications in a graphical control:
How to add mouse wheel support to a component descended from TGraphicControl?