Question

我对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;

Answer 1

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;

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?

如何“捕获”自定义组件内的onMouseWheel-Event

1 个答案: