由于几个 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
另请参阅如何将鼠标滚轮输入控制在光标下而不是聚焦？有关鼠标滚轮处理的更多背景信息和更通用的解决方案。
1)请参阅Quality Central 错误报告 #135258和Quality Central 错误报告 #135305。