如何为从TGraphicControl继承的组件添加鼠标滚轮支持？

Question

如何为从TGraphicControl继承的组件添加鼠标滚轮支持？

4

我创建了一个从TGraphicControl继承的Delphi组件。是否可以添加鼠标滚轮支持？

--- 编辑 ---

我已经按照下面所示公开了MouseWheel事件，但它们没有被调用。

TMyComponent = class(TGraphicControl)
published
  property OnMouseWheel;
  property OnMouseWheelDown;
  property OnMouseWheelUp;
end;

--- 编辑 ---

如下所建议，我尝试捕获WM_MOUSEWHEEL和CM_MOUSEWHEEL消息，但似乎并没有起作用。然而，我已经成功地捕获了CM_MOUSEENTER消息。我不明白为什么我可以捕获一种类型的消息，但不能捕获另一种类型的消息。

- Shannon

6个回答

3

TGraphicControl 是从 TControl 派生而来的，后者已经具备了鼠标滚轮支持。请参考 wm_MouseWheel 消息、DoMouseWheel、DoMouseWheelDown、DoMouseWheelUp 和 MouseWheelHandler 方法以及 WheelAccumulator 属性。

- Rob Kennedy

2

尽管如上重新声明了MouseWheel事件，但仍然有些东西缺失，它们仍未被调用。 - Shannon

看起来比我想象的要复杂。我会尝试编写一些代码来解决这个问题。请在几天后再试。 - Rob Kennedy

1

只有TWinControl的后代才能接收鼠标滚轮消息。TGraphicControl不是基于窗口的控件，因此无法接收该消息。如果VCL将消息路由到TGraphicControl，则可以工作，但显然没有这样做。您可以从TCustomControl派生，然后它将起作用。

- Lars Truijens

TGraphicControl一直在获取消息，只是不直接从操作系统获取。父控件会捕获并转发它们。有时，它们会作为CM_消息而不是WM_消息到达。看起来TControl.MouseWheelHandler会将滚轮消息转发到表单，因此Shannon可能需要重写它。 - Rob Kennedy

我尝试重写MouseWheelHandler方法，但它并不总是被调用。有时消息仍会传递到底层表单。 - Shannon

我将我的组件更改为从TCustomControl继承（我的控件需要画布进行绘制），但是MouseWheel事件处理程序仍然被忽略了。（我开始感到有点傻。哈哈）- Shannon - Shannon

1

我有同样的问题。目前还没有找到解决方案，但也许这可以帮助到你：

引起问题的原因可能是另一个组件调用了Win API方法SetCapture。根据API帮助文档所述：“SetCapture函数将鼠标捕获到当前线程所属的指定窗口。一旦窗口捕获了鼠标，所有鼠标输入都将被定向到该窗口，而不管光标是否在该窗口的边界内。一次只能有一个窗口捕获鼠标。”

作为新用户，我无法发布完整线程的链接。

编辑后：

如果将你的组件创建为TCustomControl的后代，则可以按照以下描述解决你的问题：

1.使用OnMouseEnter事件来检测鼠标何时进入你的组件。

2.在OnMouseEnter中调用SetFocus方法使你的组件获得焦点。现在，你的组件可以接收WM_MOUSEWHEEL消息。

- Wodzu

我进行了更多的实验，发现问题在于我的（以及可能是你的）组件没有焦点。如果调用SetFocusedControl(YourComponent)方法，则你的组件将开始接收来自鼠标滚轮的消息。 - Wodzu

解决这个问题的方法可以是这样的：

使用OnMouseEnter事件来检测鼠标进入您的组件时。
在OnMouseEnter中调用SetFocus方法使您的组件获得焦点。

现在您的组件可以接收WM_MOUSEWHEEL消息。 - Wodzu

@Wodzu：TGraphicControl 无法接收焦点，因为它没有窗口句柄。 - mghie

@mghie：Shannon提到他将父类更改为TCustomControl，所以这不应该是一个问题。 - Wodzu

+1，看起来需要聚焦才能接收鼠标滚轮事件（我刚试过了） - user192472

0

捕获 WM_MOUSEWHEEL 消息。

- François

我尝试过这个，但我的控件无法捕获WM_MOUSEWHEEL或CM_MOUSEWHEEL消息。但是当尝试捕获CM_MOUSEENTER消息时，它按预期工作。 - Shannon

0

我使用以下技术，订阅表单事件MouseWheelUp()，在其中使用WindowFromPoint()（win32 api函数）和Vcl.Controls.FindControl()搜索小部件，然后检查是否获得了正确的UI小部件，当没有时，检查ActiveControl（当前具有焦点的表单上的小部件）。

这种技术确保鼠标滚轮向上/向下事件在小部件位于光标下或未位于光标下但具有焦点时工作。

下面的示例对鼠标滚轮向上事件做出反应，并在TSpinEdit位于光标下或具有焦点时递增TSpinEdit。

function TFormOptionsDialog.FindSpinEdit(const AMousePos: TPoint): TSpinEdit;
var
  LWindow: HWND;
  LWinControl: TWinControl;
begin
  Result := nil;

  LWindow := WindowFromPoint(AMousePos);
  if LWindow = 0 then
    Exit;

  LWinControl := FindControl(LWindow);
  if LWinControl = nil then
    Exit;

  if LWinControl is TSpinEdit then
    Exit(LWinControl as TSpinEdit);

  if LWinControl.Parent is TSpinEdit then
    Exit(LWinControl.Parent as TSpinEdit);

  if ActiveControl is TSpinEdit then
    Exit(ActiveControl as TSpinEdit);
end;

procedure TFormOptionsDialog.FormMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint;
  var Handled: Boolean);
var
  LSpinEdit: TSpinEdit;
begin
  LSpinEdit := FindSpinEdit(MousePos);
  if LSpinEdit = nil then
    Exit;

  LSpinEdit.Value := LSpinEdit.Value + LSpinEdit.Increment;
  Handled := True;
end;

- Silver Zachara

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- NGLN · Accepted Answer

由于几个VCL结构（无论它们是否是有意的实现选择或可能是错误¹⁾，我在中途停止。只有焦点控件及其所有父级接收鼠标滚轮消息，以及具有鼠标捕获和聚焦父级的控件。

在TControl层面上，可以强制执行后一个条件。当鼠标进入控件的客户端空间时，控件会从VCL接收到CM_MOUSEENTER消息。为了强制其接收鼠标滚轮消息，请将其父级设置为焦点并在该消息处理程序中捕获鼠标：

procedure TWheelControl.CMMouseEnter(var Message: TMessage);
begin
  FPrevFocusWindow := SetFocus(Parent.Handle);
  MouseCapture := True;
  inherited;
end;

但是当鼠标离开控件时，这些设置必须撤销。由于控件现在正在捕获鼠标，因此它不会收到 CM_MOUSELEAVE 消息，所以您必须手动检查，例如在 WM_MOUSEMOVE 消息处理程序中：

procedure TWheelControl.WMMouseMove(var Message: TWMMouseMove);
begin
  if MouseCapture and
    not PtInRect(ClientRect, SmallPointToPoint(Message.Pos)) then
  begin
    MouseCapture := False;
    SetFocus(FPrevFocusWindow);
  end;
  inherited;
end;

现在，你可能会认为控件接收到的滚轮消息会随后触发 OnMouseWheel、OnMouseWheelDown 和 OnMouseWheelUp 事件。但不，还需要进行一次干预。该消息进入 MouseWheelHandler 内部，该处理程序恰好将消息传递给窗体或活动控件。要触发这些事件，应发送一个 CM_MOUSEWHEEL 控件消息：

procedure TWheelControl.MouseWheelHandler(var Message: TMessage);
begin
  Message.Result := Perform(CM_MOUSEWHEEL, Message.WParam, Message.LParam);
  if Message.Result = 0 then
    inherited MouseWheelHandler(Message);
end;

这导致最终代码如下：

unit WheelControl;

interface

uses
  System.Classes, Winapi.Windows, Winapi.Messages, Vcl.Controls;

type
  TWheelControl = class(TGraphicControl)
  private
    FPrevFocusWindow: HWND;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
  public
    procedure MouseWheelHandler(var Message: TMessage); override;
  published
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
  end;

implementation

{ TWheelControl }

procedure TWheelControl.CMMouseEnter(var Message: TMessage);
begin
  FPrevFocusWindow := SetFocus(Parent.Handle);
  MouseCapture := True;
  inherited;
end;

procedure TWheelControl.MouseWheelHandler(var Message: TMessage);
begin
  Message.Result := Perform(CM_MOUSEWHEEL, Message.WParam, Message.LParam);
  if Message.Result = 0 then
    inherited MouseWheelHandler(Message);
end;

procedure TWheelControl.WMMouseMove(var Message: TWMMouseMove);
begin
  if MouseCapture and
    not PtInRect(ClientRect, SmallPointToPoint(Message.Pos)) then
  begin
    MouseCapture := False;
    SetFocus(FPrevFocusWindow);
  end;
  inherited;
end;

end.

如您所见，这会改变焦点控件，这与 Windows桌面应用程序的用户体验指南相违背，并可能在焦点控件具有显式焦点状态时导致视觉干扰。

作为替代方案，您可以通过覆盖 Application.OnMessage 并在那里处理来绕过所有默认的VCL鼠标滚轮处理。操作如下：

unit WheelControl2;

interface

uses
  System.Classes, Winapi.Windows, Winapi.Messages, Vcl.Controls, Vcl.AppEvnts,
  Vcl.Forms;

type
  TWheelControl = class(TGraphicControl)
  published
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
  end;

implementation

type
  TWheelInterceptor = class(TCustomApplicationEvents)
  private
    procedure ApplicationMessage(var Msg: tagMSG; var Handled: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
  end;

procedure TWheelInterceptor.ApplicationMessage(var Msg: tagMSG;
  var Handled: Boolean);
var
  Window: HWND;
  WinControl: TWinControl;
  Control: TControl;
  Message: TMessage;
begin
  if Msg.message = WM_MOUSEWHEEL then
  begin
     Window := WindowFromPoint(Msg.pt);
     if Window <> 0 then
     begin
       WinControl := FindControl(Window);
       if WinControl <> nil then
       begin
         Control := WinControl.ControlAtPos(WinControl.ScreenToClient(Msg.pt),
           False);
         if Control <> nil then
         begin
           Message.WParam := Msg.wParam;
           Message.LParam := Msg.lParam;
           TCMMouseWheel(Message).ShiftState :=
             KeysToShiftState(TWMMouseWheel(Message).Keys);
           Message.Result := Control.Perform(CM_MOUSEWHEEL, Message.WParam,
             Message.LParam);
           Handled := Message.Result <> 0;
         end;
       end;
     end;
  end;
end;

constructor TWheelInterceptor.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  OnMessage := ApplicationMessage;
end;

initialization
  TWheelInterceptor.Create(Application);

end.

请注意，要将MouseWheel*事件的Handled参数设置为True，否则聚焦的控件也会滚动。

有关鼠标滚轮处理和更常见的解决方案，请参见如何将鼠标滚轮输入直接发送到光标下的控件而不是聚焦的控件？。

请参见¹⁾Quality Central bug report #135258和Quality Central bug report #135305。