如何在自定义组件中 "catch" onMouseWheel-Event
How to "catch" onMouseWheel-Event inside a custom component
我对 Delphi 很陌生,想练习一下。
在尝试实现基本的自定义组件时,我不知道如何 "catch" 事件,例如 "OnMouseWheel" 或 "OnMouseMove" 等。
(该组件应该让用户放大 TImage)
目前我写了一些 public 函数,如 LMouseWheel(...),现在组件的用户必须实现 OnMouseWheel-Function,但只需要调用 public MouseWheel(...) - 使组件工作的方法。有没有办法默认调用 MouseWheel-Method?
该代码是我的自定义组件的摘要。当用户在我的组件上滚动鼠标滚轮时,我必须做什么才能立即调用 LMouseWheel(...) 方法?
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.
解决方法:
最简单的解决方案是,从 TControl 中覆盖以下过程/函数,感谢 "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 的 VCL TControl
具有虚拟 DoMouseWheel(Down|Up)()
和 Mouse(Down|Move|Up)()
方法,您的组件可以根据需要 override
:
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 的 FMX TControl
具有虚拟 Mouse(Down|Move|Up|Wheel)()
方法:
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 的 TControl
具有镜像 VCL 的虚拟 Mouse(Down|Move|Up)()
和 DoMouseWheel(Down|Up)()
方法,以及其他虚拟 DoMouseWheel(Horz|Left|Right)
方法:
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;
在所有情况下,框架都会处理从 OS 捕获实际鼠标事件,然后根据需要自动调用每个组件的虚拟方法。这甚至适用于图形控件,因为父窗口控件将检测鼠标 activity 在图形子控件上并相应地委托。
更新:在 Delphi 的 VCL TControl
的情况下(不确定 Delphi 的 FMX TControl
,或 FreePascal 的 TControl
),鼠标委派 clicks 按预期工作,但鼠标委派 wheel 移动没有。您必须采取一些额外的步骤才能在图形控件中接收鼠标滚轮通知:
How to add mouse wheel support to a component descended from TGraphicControl?
我对 Delphi 很陌生,想练习一下。
在尝试实现基本的自定义组件时,我不知道如何 "catch" 事件,例如 "OnMouseWheel" 或 "OnMouseMove" 等。 (该组件应该让用户放大 TImage)
目前我写了一些 public 函数,如 LMouseWheel(...),现在组件的用户必须实现 OnMouseWheel-Function,但只需要调用 public MouseWheel(...) - 使组件工作的方法。有没有办法默认调用 MouseWheel-Method?
该代码是我的自定义组件的摘要。当用户在我的组件上滚动鼠标滚轮时,我必须做什么才能立即调用 LMouseWheel(...) 方法?
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.
解决方法: 最简单的解决方案是,从 TControl 中覆盖以下过程/函数,感谢 "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 的 VCL TControl
具有虚拟 DoMouseWheel(Down|Up)()
和 Mouse(Down|Move|Up)()
方法,您的组件可以根据需要 override
:
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 的 FMX TControl
具有虚拟 Mouse(Down|Move|Up|Wheel)()
方法:
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 的 TControl
具有镜像 VCL 的虚拟 Mouse(Down|Move|Up)()
和 DoMouseWheel(Down|Up)()
方法,以及其他虚拟 DoMouseWheel(Horz|Left|Right)
方法:
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;
在所有情况下,框架都会处理从 OS 捕获实际鼠标事件,然后根据需要自动调用每个组件的虚拟方法。这甚至适用于图形控件,因为父窗口控件将检测鼠标 activity 在图形子控件上并相应地委托。
更新:在 Delphi 的 VCL TControl
的情况下(不确定 Delphi 的 FMX TControl
,或 FreePascal 的 TControl
),鼠标委派 clicks 按预期工作,但鼠标委派 wheel 移动没有。您必须采取一些额外的步骤才能在图形控件中接收鼠标滚轮通知:
How to add mouse wheel support to a component descended from TGraphicControl?