delphi - 如何为 TGraphicControl 的后代组件添加鼠标滚轮支持？

Question

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

--- 编辑 ---

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

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

--- 编辑 ---

正如下面所建议的，我 try catch WM_MOUSEWHEEL 和 CM_MOUSEWHEEL 消息，但它似乎不起作用。不过我已经成功捕获了 CM_MOUSEENTER 消息。我不明白为什么我可以捕获一种类型的消息，但不能捕获另一种类型的消息。

Answer 1

由于几个 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.

如您所见，这会更改聚焦控件，这与user experience guidelines for Windows-based desktop applications相悖。当聚焦控件具有明确的聚焦状态时，可能会导致视觉干扰。

作为替代方案，您可以通过重写 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，否则获得焦点的控件也会滚动。

另请参阅How to direct the mouse wheel input to control under cursor instead of focused?了解有关鼠标滚轮处理的更多背景知识和更通用的解决方案。

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