如何将鼠标滚轮输入直接控制光标所在位置而非选中窗口？

Question

如何将鼠标滚轮输入直接控制光标所在位置而非选中窗口？

delphimousewheel

42

我使用多种滚动控件：TTreeViews、TListViews、DevExpress cxGrids 和 cxTreeLists 等等。当鼠标滚轮旋转时，无论鼠标光标停留在哪个控件上，都会将焦点控制权交给具有焦点的控件。

你如何将鼠标滚轮输入直接传递给鼠标光标所在的控件呢？Delphi IDE 在这方面表现得非常好。

- avenmore

https://dev59.com/NFXTa4cB1Zd3GeqPzTE1 - Shannon Matthews

1

相关链接：http://stackoverflow.com/questions/34145952/how-to-prevent-focused-control-from-scrolling-when-the-mouse-isnt-over-it - Jerry Dodge

8个回答

24

尝试像这样覆盖表单的MouseWheelHandler方法（我没有彻底测试过）：

procedure TMyForm.MouseWheelHandler(var Message: TMessage);
var
  Control: TControl;
begin
  Control := ControlAtPos(ScreenToClient(SmallPointToPoint(TWMMouseWheel(Message).Pos)), False, True, True);
  if Assigned(Control) and (Control <> ActiveControl) then
  begin
    Message.Result := Control.Perform(CM_MOUSEWHEEL, Message.WParam, Message.LParam);
    if Message.Result = 0 then
      Control.DefaultHandler(Message);
  end
  else
    inherited MouseWheelHandler(Message);

end;

- Ondrej Kelle

2

几乎可以工作了。ControlAtPos() 获取直接子控件，所以如果控件在面板中，则返回面板。FindVCLWindow(Mouse.CursorPos) 返回正确的控件。只有DevExpress TcxTreeList滚动太多 - 似乎滚动了3倍。 - avenmore

这个解决方案最终对我起了作用。解决过度滚动的方法是设置Message.Result := 1。会注意FindVCLWindow的限制。感谢您的帮助。 - avenmore

我已经提交了QC报告82143，关于ControlAtPos实现中似乎存在的错误，无法找到嵌套的子控件： http://qc.embarcadero.com/wc/qcmain.aspx?d=82143 - Ondrej Kelle

3

由于某种原因，当我在TMyForm上方滚动时，这段代码会产生堆栈溢出。 - Kromster

2

当MouseWheelHandler函数是传递给控件的MouseWheelHandler时，此代码在正确情况下可能会产生StackOverflow。我通过在我的表单中添加一个“ScrollControl”变量来解决这个问题，在调用“Perform”之前设置它，并与ActiveControl一起检查，以便它不会无限递归。最后应该设置为nil。 - kbickar

1

这让我遇到了堆栈溢出的问题，而且也没有起到作用。下面Zoe的答案起了一定的作用，但并不完全。它不能滚动TScrollBox，当TDBGrid获得焦点时，它仍然会捕获焦点。 - Jerry Dodge

7

覆盖TApplication.OnMessage事件（或创建TApplicationEvents组件），并在事件处理程序中重定向WM_MOUSEWHEEL消息：

procedure TMyForm.AppEventsMessage(var Msg: tagMSG;
  var Handled: Boolean);
var
  Pt: TPoint;
  C: TWinControl;
begin
  if Msg.message = WM_MOUSEWHEEL then begin
    Pt.X := SmallInt(Msg.lParam);
    Pt.Y := SmallInt(Msg.lParam shr 16);
    C := FindVCLWindow(Pt);
    if C = nil then 
      Handled := True
    else if C.Handle <> Msg.hwnd then begin
      Handled := True;
      SendMessage(C.Handle, WM_MOUSEWHEEL, Msg.wParam, Msg.lParam);
    end;
   end;
end;

这里的代码运行良好，不过您可能需要添加一些保护措施，以防发生意外情况时出现递归。

- Zoë Peterson

1

我认为这是最好的答案。问题在于，一个专注的DevExpress控件仍然拦截了这个消息。如果我调用C.Perform()而不是SendMessage()，那么DevExpress控件可以工作，但常规控件不能。必须在DevExpress源代码中进行一些挖掘以禁用此钩子。 - avenmore

最终我放弃了这个解决方案，因为似乎焦点 TControl（与DevExpress无关）总是拦截该消息。 - avenmore

1

这是我能找到的最接近的，但仍然不起作用。正如提到的那样，一个聚焦的控件总是会滚动。即使例如TDBGrid拥有焦点，但鼠标正在滚动其他内容，它仍然会滚动TDBGrid。 - Jerry Dodge

我注意到这在XE8上有效，但在10 Seattle上不起作用，至少在我的环境中是如此。 - benok

2

这是我一直在使用的解决方案：

Add amMouseWheel to the uses clause of the implementation section of the unit of your form after the forms unit:

unit MyUnit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  // Fix and util for mouse wheel
  amMouseWheel;
...

Save the following code to amMouseWheel.pas:

unit amMouseWheel;

// -----------------------------------------------------------------------------
// The original author is Anders Melander, anders@melander.dk, http://melander.dk
// Copyright © 2008 Anders Melander
// -----------------------------------------------------------------------------
// License:
// Creative Commons Attribution-Share Alike 3.0 Unported
// http://creativecommons.org/licenses/by-sa/3.0/
// -----------------------------------------------------------------------------

interface

uses
  Forms,
  Messages,
  Classes,
  Controls,
  Windows;

//------------------------------------------------------------------------------
//
//      TForm work around for mouse wheel messages
//
//------------------------------------------------------------------------------
// The purpose of this class is to enable mouse wheel messages on controls
// that doesn't have the focus.
//
// To scroll with the mouse just hover the mouse over the target control and
// scroll the mouse wheel.
//------------------------------------------------------------------------------
type
  TForm = class(Forms.TForm)
  public
    procedure MouseWheelHandler(var Msg: TMessage); override;
  end;

//------------------------------------------------------------------------------
//
//      Generic control work around for mouse wheel messages
//
//------------------------------------------------------------------------------
// Call this function from a control's (e.g. a TFrame) DoMouseWheel method like
// this:
//
// function TMyFrame.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
//   MousePos: TPoint): Boolean;
// begin
//   Result := ControlDoMouseWheel(Self, Shift, WheelDelta, MousePos) or inherited;
// end;
//
//------------------------------------------------------------------------------
function ControlDoMouseWheel(Control: TControl; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint): Boolean;

implementation

uses
  Types;

procedure TForm.MouseWheelHandler(var Msg: TMessage);
var
  Target: TControl;
begin
  // Find the control under the mouse
  Target := FindDragTarget(SmallPointToPoint(TCMMouseWheel(Msg).Pos), False);

  while (Target <> nil) do
  begin
    // If the target control is the focused control then we abort as the focused
    // control is the originator of the call to this method.
    if (Target = Self) or ((Target is TWinControl) and (TWinControl(Target).Focused)) then
    begin
      Target := nil;
      break;
    end;

    // Let the target control process the scroll. If the control doesn't handle
    // the scroll then...
    Msg.Result := Target.Perform(CM_MOUSEWHEEL, Msg.WParam, Msg.LParam);
    if (Msg.Result <> 0) then
      break;

    // ...let the target's parent give it a go instead.
    Target := Target.Parent;
  end;

  // Fall back to the default processing if none of the controls under the mouse
  // could handle the scroll.
  if (Target = nil) then
    inherited;
end;

type
  TControlCracker = class(TControl);

function ControlDoMouseWheel(Control: TControl; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint): Boolean;
var
  Target: TControl;
begin
  (*
  ** The purpose of this method is to enable mouse wheel messages on controls
  ** that doesn't have the focus.
  **
  ** To scroll with the mouse just hover the mouse over the target control and
  ** scroll the mouse wheel.
  *)
  Result := False;

  // Find the control under the mouse
  Target := FindDragTarget(MousePos, False);

  while (not Result) and (Target <> nil) do
  begin
    // If the target control is the focused control then we abort as the focused
    // control is the originator of the call to this method.
    if (Target = Control) or ((Target is TWinControl) and (TWinControl(Target).Focused)) then
      break;

    // Let the target control process the scroll. If the control doesn't handle
    // the scroll then...
    Result := TControlCracker(Target).DoMouseWheel(Shift, WheelDelta, MousePos);

    // ...let the target's parent give it a go instead.
    Target := Target.Parent;
  end;
end;

end.

- SpeedFreak

这对我完全没有作用。 - Jerry Dodge

@JerryDodge 在我使用的所有地方都运行良好，我也听说它对其他人也有效。由于您没有描述您所做的事情，我无法真正评论为什么它对您不起作用。您应该发布一个新问题，详细说明您特定的要求和问题。 - SpeedFreak

我说话太早了，忘记回来编辑了，抱歉。它可以工作，但不完全。核心问题是，如果另一个控件当前具有焦点，则仍会滚动，例如TDBGrid（在我们的应用程序中广泛使用）。因此，我最终会有两个控件同时滚动。实际上，我在这个问题上开始了一项赏金，因为提出一个新问题只会被标记为重复。 - Jerry Dodge

@JerryDodge 你使用的是哪个版本的Delphi？你是使用TForm.MouseWheelHandler解决方案还是ControlDoMouseWheel()解决方案？尝试在Perform(CM_MOUSEWHEEL)/DoMouseWheel()调用处设置断点。目标是否返回正确的值（即指示它处理了事件的值）？如果目标返回不正确的值，则会出现你看到的症状。 - SpeedFreak

2

你可能会发现这篇文章有用：使用鼠标滚轮向列表框发送滚动消息，但列表框没有焦点[1]，该文章是用C#编写的，但转换为Delphi应该不是什么大问题。它使用钩子来实现想要的效果。

要找出鼠标当前所在的组件，可以使用FindVCLWindow函数，这篇文章中有一个例子：在Delphi应用程序中获取鼠标下的控件[2]。

[1] http://social.msdn.microsoft.com/forums/en-US/winforms/thread/ec1fbfa2-137e-49f6-b444-b634e4f44f21/
[2] http://delphi.about.com/od/delphitips2008/qt/find-vcl-window.htm

- Tommy Andersen

0

我曾经遇到同样的问题，但通过一些小技巧解决了它，现在它可以正常工作。

我不想去处理消息，所以决定直接调用DoMouseWheel方法来控制我需要的内容。技巧在于DoMouseWheel是受保护的方法，因此无法从表单单元文件中访问，这就是为什么我在表单单元中定义了我的类：

TControlHack = class(TControl)
end;  //just to call DoMouseWheel

然后我编写了TForm1.onMouseWheel事件处理程序：

procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
    WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var i: Integer;
    c: TControlHack;
begin
  for i:=0 to ComponentCount-1 do
    if Components[i] is TControl then begin
      c:=TControlHack(Components[i]);
      if PtInRect(c.ClientRect,c.ScreenToClient(MousePos)) then 
      begin
        Handled:=c.DoMouseWheel(shift,WheelDelta,MousePos);
        if Handled then break;
      end;
   end;
end;

正如你所见，它在表格上搜索所有控件，不仅限于直接子代，并且搜索顺序是从父级到子级。更好的做法（但需要更多代码）是在子级进行递归搜索，但上面的代码也可以正常工作。

要使一个控件响应鼠标滚轮事件，当其被实现时，你应该总是设置 Handled:=true。例如，如果你在面板内部有列表框，则面板将首先执行 DoMouseWheel，如果它没有处理事件，则 listbox.DoMouseWheel 将执行。如果鼠标指针下没有控件处理 DoMouseWheel，则聚焦的控件会处理，这似乎是相当足够的行为。

- Yuriy Afanasenkov

谢谢，但这没有帮助到我。和我在其他答案评论中描述的问题相同。 - Jerry Dodge

至少我认为在这段代码中不会出现堆栈溢出（这是不可能的）。滚动框是否按预期工作？ - Yuriy Afanasenkov

0

只适用于DevExpress控件

它适用于XE3版本，未在其他版本上测试过。

procedure TMainForm.DoApplicationMessage(var AMsg: TMsg; var AHandled: Boolean);
var
  LControl: TWinControl;
  LMessage: TMessage;
begin

  if AMsg.message <> WM_MOUSEWHEEL then
    Exit;

  LControl := FindVCLWindow(AMsg.pt);
  if not Assigned(LControl) then
    Exit;

  LMessage.WParam := AMsg.wParam;
  // see TControl.WMMouseWheel
  TCMMouseWheel(LMessage).ShiftState := KeysToShiftState(TWMMouseWheel(LMessage).Keys);
  LControl.Perform(CM_MOUSEWHEEL, LMessage.WParam, AMsg.lParam);

  AHandled := True;

end;

如果您不使用DevExpress控件，则可以使用Perform -> SendMessage。

SendMessage(LControl.Handle, AMsg.message, AMsg.WParam, AMsg.lParam);

- Sikambr

-2

在每个可滚动控件的OnMouseEnter事件中，分别添加对SetFocus的调用。

所以对于ListBox1：

procedure TForm1.ListBox1MouseEnter(Sender: TObject);  
begin  
    ListBox1.SetFocus;  
end;

这样做能达到预期的效果吗？

- user271963

10

不，这对于一个程序来说是不良行为。 - avenmore

这将严重改变用户体验。并不是每个人都使用过 X 窗口管理器，其中你必须移动鼠标以便切换窗口焦点。 - Ritsaert Hornstra

这将是一种可怕的用户体验。焦点非常重要。只有用户应该决定何时设置焦点。 - Jerry Dodge

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

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

- NGLN · Accepted Answer

滚动起源

使用鼠标滚轮会发送一个WM_MOUSEWHEEL消息：

当鼠标滚轮旋转时，该消息将被发送到焦点窗口。DefWindowProc函数将该消息传递给窗口的父级。不应该内部转发消息，因为DefWindowProc将其沿着父级链传播直到找到处理它的窗口。

鼠标滚轮的漫长历程 ¹⁾

用户滚动鼠标滚轮。
系统将 WM_MOUSEWHEEL 消息放入前台窗口线程的消息队列中。
线程的消息循环从队列中获取消息（Application.ProcessMessage）。此消息类型为 TMsg，具有指定消息所属窗口句柄的 hwnd 成员。
触发 Application.OnMessage 事件。
1. 设置 Handled 参数为 True 将停止消息的进一步处理（除了下面两个步骤）。
调用 Application.IsPreProcessMessage 方法。
1. 如果没有控件捕获鼠标，则调用焦点控件的 PreProcessMessage 方法，默认情况下不执行任何操作。VCL 中的任何控件都未覆盖此方法。
调用 Application.IsHintMsg 方法。
1. 活动提示窗口使用覆盖的 IsHintMsg 方法处理该消息。无法阻止消息的进一步处理。
调用 DispatchMessage。
焦点窗口的 TWinControl.WndProc 方法接收该消息。此消息类型为 TMessage，缺少窗口（因为这是调用该方法的实例）。
调用 TWinControl.IsControlMouseMsg 方法以检查鼠标消息是否应定向到其非窗口子控件之一。
1. 如果有一个已捕获鼠标或位于当前鼠标位置²⁾ 的子控件，则将消息发送到该子控件的 WndProc 方法，参见步骤 10。（²⁾ 这将永远不会发生，因为 WM_MOUSEWHEEL 包含其屏幕坐标中的鼠标位置，而 IsControlMouseMsg 假设鼠标位置为客户端坐标（XE2）。）
继承的 TControl.WndProc 方法接收该消息。
1. 当系统不原生支持鼠标滚轮（< Win98 或 < WinNT4.0）时，将消息转换为 CM_MOUSEWHEEL 消息，并将其发送到 TControl.MouseWheelHandler，参见步骤 13。
2. 否则将消息分派到适当的消息处理程序。
调用 TControl.WMMouseWheel 方法以接收该消息。
将有意义的 WM_MOUSEWHEEL 窗口消息（对系统和 VCL 通常也有意义）转换为仅对 VCL 有意义的 CM_MOUSEWHEEL 控件消息，该消息提供方便的 VCL 的 ShiftState 信息而不是系统的键数据。

调用控件的 MouseWheelHandler 方法。

如果控件是 TCustomForm，则调用 TCustomForm.MouseWheelHandler 方法。

如果有一个焦点控件，则将 CM_MOUSEWHEEL 发送到该控件，参见步骤 14。
否则调用继承的方法，参见步骤 13.2。

在消息处理的每个步骤中，可以通过什么都不做来忽略该消息，通过更改消息参数来修改它，通过对其进行操作来处理它，并通过设置 Handled := True 或将 Message.Result 设置为非零值来取消它。

只有当某个控件具有焦点时，应用程序才会收到该消息。但是，即使强制将 Screen.ActiveCustomForm.ActiveControl 设置为 nil，VCL 也会使用 TCustomForm.SetWindowFocus 确保具有焦点的控件，默认为先前活动的窗体。（使用 Windows.SetFocus(0)，确实不会发送该消息。）

IsControlMouseMsg

²⁾

TControl

WM_MOUSEWHEEL

这可以通过手动设置

Control.MouseCapture := True

鼠标捕获

MouseWheelHandler

TControl

MouseWheelHandler

原生控件，如TMemo、TListBox、TDateTimePicker、TComboBox、TTreeView、TListView等，能够随滚轮滚动，由系统自己滚动。默认情况下，向这样的控件发送CM_MOUSEWHEEL没有效果。这些子类化的控件通过发送WM_MOUSEWHEEL消息到与其关联的API窗口过程中CallWindowProc，由VCL在TWinControl.DefaultHandler中处理滚动。奇怪的是，在调用CallWindowProc之前，这个例程没有检查Message.Result，一旦消息被发送，就无法防止滚动。该消息返回时，其Result根据控件是否通常能够滚动或控件类型而设置。（例如，TMemo返回<> 0，TEdit返回0）。它是否实际滚动对消息结果没有影响。

VCL控件依赖于TControl和TWinControl中实现的默认处理方式，如上所述。它们通过DoMouseWheel、DoMouseWheelDown或DoMouseWheelUp来处理滚轮事件。据我所知，VCL中没有任何控件覆盖了MouseWheelHandler以处理滚轮事件。

从不同的应用程序来看，似乎没有一致的标准来规定滚轮滚动的行为。例如：MS Word滚动悬停的页面，MS Excel滚动聚焦的工作簿，Windows资源管理器滚动聚焦的窗格，网站实现了各种不同的滚动行为，Evernote滚动悬停的窗口等等...而Delphi自己的IDE则通过滚动聚焦的窗口以及悬停的窗口来顶替一切，除非在悬停代码编辑器时，当你滚动时，代码编辑器会抢占焦点（XE2）。

幸运的是，微软至少提供了user experience guidelines for Windows-based desktop applications：

使鼠标滚轮只影响指针当前所在的控件、窗格或窗口。 这样可以避免意外结果。

使鼠标滚轮在没有单击或输入焦点的情况下生效。 悬停就足够了。

使鼠标滚轮影响具有最具体范围的对象。 例如，如果指针位于可滚动窗口内的可滚动窗格中的可滚动列表框控件上，则鼠标滚轮影响列表框控件。

使用鼠标滚轮时不要更改输入焦点。

因此，问题要求仅滚动悬停的控件是有足够的依据的，但Delphi的开发人员并没有简化其实现方式。

结论和解决方案

首选的解决方案是不需要子类化窗口或为不同的窗体或控件实现多个方案。

CM_MOUSEWHEEL

MouseWheelHandler

WM_MOUSEWHEEL

TApplication.OnMessage

WindowFromPoint

procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
var
  Window: HWND;
begin
  if Msg.message = WM_MOUSEWHEEL then
  begin
    Window := WindowFromPoint(Msg.pt);
    if Window <> 0 then
    begin

      Handled := True;
    end;
  end;
end;

FindControl

nil

TDateTimePicker

  WinControl: TWinControl;
  WndProc: NativeInt;

      WinControl := FindControl(Window);
      if WinControl = nil then
      begin
        WndProc := GetWindowLongPtr(Window, GWL_WNDPROC);
        CallWindowProc(Pointer(WndProc), Window, Msg.message, Msg.wParam,
          Msg.lParam);
      end
      else
      begin

      end;

当窗口是VCL控件时，需要考虑调用多个消息处理程序，按特定顺序进行。当鼠标位置上有一个启用的非窗口控件（类型为TControl或其子类）时，它首先应该获得CM_MOUSEWHEEL消息，因为该控件肯定是前景控件。该消息应从WM_MOUSEWHEEL消息构造，并转换为其VCL等效形式。其次，必须将WM_MOUSEWHEEL消息发送到控件的DefaultHandler方法以允许本地控件处理。最后，如果没有先前的处理程序处理消息，则再次将CM_MOUSEWHEEL消息发送到控件。这后两步不能颠倒顺序，因为例如滚动框中的备忘录也必须能够滚动。

  Point: TPoint;
  Message: TMessage;

        Point := WinControl.ScreenToClient(Msg.pt);
        Message.WParam := Msg.wParam;
        Message.LParam := Msg.lParam;
        TCMMouseWheel(Message).ShiftState :=
          KeysToShiftState(TWMMouseWheel(Message).Keys);
        Message.Result := WinControl.ControlAtPos(Point, False).Perform(
          CM_MOUSEWHEEL, Message.WParam, Message.LParam);
        if Message.Result = 0 then
        begin
          Message.Msg := Msg.message;
          Message.WParam := Msg.wParam;
          Message.LParam := Msg.lParam;
          WinControl.DefaultHandler(Message);
        end;
        if Message.Result = 0 then
        begin
          Message.WParam := Msg.wParam;
          Message.LParam := Msg.lParam;
          TCMMouseWheel(Message).ShiftState :=
            KeysToShiftState(TWMMouseWheel(Message).Keys);
          Message.Result := WinControl.Perform(CM_MOUSEWHEEL, Message.WParam,
            Message.LParam);
        end;

GetCapture

TDragObject.DragHandle

WM_MOUSEWHEEL

Form.OnMouseWheel

    Window := GetCapture;
    if Window <> 0 then
    begin
      Message.Result := GetCaptureControl.Perform(CM_MOUSEWHEEL, Message.WParam,
        Message.LParam);
      if Message.Result = 0 then
        Message.Result := SendMessage(Window, Msg.message, Msg.wParam,
          Msg.lParam);
    end;

在主窗体、活动窗体或活动控件中预览滚轮操作的可能性。
注册控件类，以调用其MouseWheelHandler方法。
将此TApplicationEvents对象置于所有其他对象之前。
取消将OnMessage事件分派给所有其他TApplicationEvents对象的可能性。
仍允许进行默认的VCL处理，以进行分析或测试目的。

ScrollAnywhere.pas

unit ScrollAnywhere;

interface

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

type
  TWheelMsgSettings = record
    MainFormPreview: Boolean;
    ActiveFormPreview: Boolean;
    ActiveControlPreview: Boolean;
    VclHandlingAfterHandled: Boolean;
    VclHandlingAfterUnhandled: Boolean;
    CancelApplicationEvents: Boolean;
    procedure RegisterMouseWheelHandler(ControlClass: TControlClass);
  end;

  TMouseHelper = class helper for TMouse
  public
    class var WheelMsgSettings: TWheelMsgSettings;
  end;

procedure Activate;

implementation

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

var
  WheelInterceptor: TWheelInterceptor;
  ControlClassList: TClassList;

procedure TWheelInterceptor.ApplicationMessage(var Msg: tagMSG;
  var Handled: Boolean);
var
  Window: HWND;
  WinControl: TWinControl;
  WndProc: NativeInt;
  Message: TMessage;
  OwningProcess: DWORD;

  procedure WinWParamNeeded;
  begin
    Message.WParam := Msg.wParam;
  end;

  procedure VclWParamNeeded;
  begin
    TCMMouseWheel(Message).ShiftState :=
      KeysToShiftState(TWMMouseWheel(Message).Keys);
  end;

  procedure ProcessControl(AControl: TControl;
    CallRegisteredMouseWheelHandler: Boolean);
  begin
    if (Message.Result = 0) and CallRegisteredMouseWheelHandler and
      (AControl <> nil) and
      (ControlClassList.IndexOf(AControl.ClassType) <> -1) then
    begin
      AControl.MouseWheelHandler(Message);
    end;
    if Message.Result = 0 then
      Message.Result := AControl.Perform(CM_MOUSEWHEEL, Message.WParam,
        Message.LParam);
  end;

begin
  if Msg.message <> WM_MOUSEWHEEL then
    Exit;
  with Mouse.WheelMsgSettings do
  begin
    Message.Msg := Msg.message;
    Message.WParam := Msg.wParam;
    Message.LParam := Msg.lParam;
    Message.Result := LRESULT(Handled);
    // Allow controls for which preview is set to handle the message
    VclWParamNeeded;
    if MainFormPreview then
      ProcessControl(Application.MainForm, False);
    if ActiveFormPreview then
      ProcessControl(Screen.ActiveCustomForm, False);
    if ActiveControlPreview then
      ProcessControl(Screen.ActiveControl, False);
    // Allow capturing control to handle the message
    Window := GetCapture;
    if (Window <> 0) and (Message.Result = 0) then
    begin
      ProcessControl(GetCaptureControl, True);
      if Message.Result = 0 then
        Message.Result := SendMessage(Window, Msg.message, Msg.wParam,
          Msg.lParam);
    end;
    // Allow hovered control to handle the message
    Window := WindowFromPoint(Msg.pt);
    if (Window <> 0) and (Message.Result = 0) then
    begin
      WinControl := FindControl(Window);
      if WinControl = nil then
      begin
        // Window is a non-VCL window (e.g. a dropped down TDateTimePicker), or
        // the window doesn't belong to this process
        WndProc := GetWindowLongPtr(Window, GWL_WNDPROC);
        Message.Result := CallWindowProc(Pointer(WndProc), Window,
          Msg.message, Msg.wParam, Msg.lParam);
      end
      else
      begin
        // Window is a VCL control
        // Allow non-windowed child controls to handle the message
        ProcessControl(WinControl.ControlAtPos(
          WinControl.ScreenToClient(Msg.pt), False), True);
        // Allow native controls to handle the message
        if Message.Result = 0 then
        begin
          WinWParamNeeded;
          WinControl.DefaultHandler(Message);
        end;
        // Allow windowed VCL controls to handle the message
        if not ((MainFormPreview and (WinControl = Application.MainForm)) or
          (ActiveFormPreview and (WinControl = Screen.ActiveCustomForm)) or
          (ActiveControlPreview and (WinControl = Screen.ActiveControl))) then
        begin
          VclWParamNeeded;
          ProcessControl(WinControl, True);
        end;
      end;
    end;
    // Bypass default VCL wheel handling?
    Handled := ((Message.Result <> 0) and not VclHandlingAfterHandled) or
      ((Message.Result = 0) and not VclHandlingAfterUnhandled);
    // Modify message destination for current process
    if (not Handled) and (Window <> 0) and
      (GetWindowThreadProcessID(Window, OwningProcess) <> 0) and
      (OwningProcess = GetCurrentProcessId) then
    begin
      Msg.hwnd := Window;
    end;
    if CancelApplicationEvents then
      CancelDispatch;
  end;
end;

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

procedure Activate;
begin
  WheelInterceptor.Activate;
end;

{ TWheelMsgSettings }

procedure TWheelMsgSettings.RegisterMouseWheelHandler(
  ControlClass: TControlClass);
begin
  ControlClassList.Add(ControlClass);
end;

initialization
  ControlClassList := TClassList.Create;
  WheelInterceptor := TWheelInterceptor.Create(Application);

finalization
  ControlClassList.Free;

end.

免责声明：

这段代码故意不会滚动任何内容，它只是为了准备消息路由以便VCL的OnMouseWheel*事件得到适当的机会来触发。这段代码没有在第三方控件上进行测试。当设置VclHandlingAfterHandled或VclHandlingAfterUnhandled为True时，鼠标事件可能会被触发两次。在本文中，我提出了一些观点，并认为VCL中存在三个错误，但这都是基于对文档的研究和测试。请务必测试此单元并评论发现的错误。对于这个相当长的答案，我表示歉意；我只是没有博客。

¹⁾ 命名取自A Key’s Odyssey

²⁾ 请参阅我的Quality Central bug report #135258

³⁾ 请参阅我的Quality Central bug report #135305

如何将鼠标滚轮输入直接控制光标所在位置而非选中窗口？

滚动起源

鼠标滚轮的漫长历程 1)

结论和解决方案

ScrollAnywhere.pas

鼠标滚轮的漫长历程 ¹⁾