我对Delphi很陌生,想要练习一点。
在尝试实现一个基本的自定义组件时,我无法弄清楚如何“捕获”像“OnMouseWheel”或“OnMouseMove”等事件。(该组件应该让用户放大到TImage)
目前我写了一些公共函数,如LMouseWheel(...),现在组件的用户必须实现OnMouseWheel-Function,但只需要调用公共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.
解决方案:最简单的解决方案是,通过“Remy Lebeau”覆盖TControl中的以下过程/功能:
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;
德尔福的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 qazxsw poi有虚拟qazxsw poi方法:
TControl
FreePascal的Mouse(Down|Move|Up|Wheel)()
具有镜像VCL的虚拟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;
和TControl
方法,以及其他虚拟Mouse(Down|Move|Up)()
方法:
DoMouseWheel(Down|Up)()
在所有情况下,框架处理从OS捕获实际鼠标事件,然后根据需要自动调用每个组件的虚拟方法。这甚至适用于图形控件,因为父窗口控件将检测图形子控件上的鼠标活动并相应地委托。
更新:在Delphi的VCL DoMouseWheel(Horz|Left|Right)
(不确定Delphi的FMX 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;
或FreePascal的TControl
)的情况下,鼠标点击的授权按预期工作,但鼠标滚轮移动的委托不会。您必须采取一些额外步骤才能在图形控件中接收鼠标滚轮通知:
TControl