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

Question

我创建了一个源自 TGraphicControl 的 delphi 组件。是否可以添加对鼠标滚轮的支持？

- - 编辑 - -

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

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

- - 编辑 - -

正如下面所建议的，我试图捕获 WM_MOUSEWHEEL 和 CM_MOUSEWHEEL 消息，但它似乎不起作用。但是我设法捕获了 CM_MOUSEENTER 消息。我不明白为什么我可以捕获一种类型的消息，而不能捕获另一种。

Answer 1

由于几个 VCL 构造（无论它们是故意的实现选择还是可能是错误^1），我留在中间）只有焦点控件及其所有父项获得鼠标滚轮消息，以及捕获鼠标的控件和有一个专注的父母。

在TControl级别上，可以强制执行后一个条件。CM_MOUSEENTER当鼠标进入控件的客户空间时，控件会收到来自 VCL的消息。要强制它接收鼠标滚轮消息，请关注其父级并在该消息处理程序中捕获鼠标：

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.

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

另请参阅如何将鼠标滚轮输入引导到光标下而不是聚焦下？有关鼠标滚轮处理的更多背景信息和更通用的解决方案。

¹⁾请参阅质量中心错误报告 #135258和质量中心错误报告 #135305。