我对Delphi很陌生,想练习一点。
在尝试实现基本的自定义组件时,我无法弄清楚如何“捕获”诸如“ OnMouseWheel”或“ OnMouseMove”等事件。 (该组件只应让用户放大一个TImage)
此刻,我编写了一些公共函数,例如LMouseWheel(...),现在该组件的用户必须实现OnMouseWheel-Function,但只需调用公共MouseWheel(...)-Method即可组件正常工作。有没有办法默认调用MouseWheel-Method?
代码是我的自定义组件的摘要。当用户在我的组件上滚动鼠标滚轮时,我要怎么做才能立即调用LMouseWheel(...)-Method?
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;
答案 0 :(得分:0)
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捕获实际鼠标事件的行为,然后根据需要自动调用每个组件的虚拟方法。甚至对于图形控件也可以使用,因为父窗口控件将检测图形子控件上的鼠标活动并相应地委派。
更新:对于Delphi的VCL TControl
(不确定Delphi的FMX TControl
或FreePascal的TControl
),鼠标的委派clicks 可以正常工作,但是鼠标 wheel 动作的委派则不起作用。您必须采取一些额外的步骤才能在图形控件中接收鼠标滚轮通知:
How to add mouse wheel support to a component descended from TGraphicControl?