当前位置： 文江博客 话题详情

如何将鼠标滚轮输入定向到光标下方进行控制而不是聚焦？

发布于 2024-08-21 05:17:09 字数 168 浏览 8 评论 0 原文

我使用了许多滚动控件：TTreeViews、TListViews、DevExpress cxGrids 和 cxTreeLists 等。当鼠标滚轮旋转时，无论鼠标光标位于哪个控件上，具有焦点的控件都会接收输入。

如何将鼠标滚轮输入定向到鼠标光标所在的任何控件？ Delphi IDE 在这方面工作得非常好。

原文

I use a number of scrolling controls: TTreeViews, TListViews, DevExpress cxGrids and cxTreeLists, etc. When the mouse wheel is spun, the control with focus receives the input no matter what control the mouse cursor is over.

How do you direct the mouse wheel input to whatever control the mouse cursor is over? The Delphi IDE works very nicely in this regard.

如果你对这篇内容有疑问，欢迎到本站社区发帖提问 参与讨论，获取更多帮助，或者扫码二维码加入 Web 技术交流群。

扫码二维码加入Web技术交流群

发布评论

需要 登录 才能够评论， 你可以免费 注册 一个本站的账号。

评论（8）

无人问我粥可暖 2024-08-28 05:17:09

滚动原点

使用鼠标滚轮进行操作会生成 WM_MOUSEWHEEL 消息 正在发送：

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

鼠标滚轮的奥德赛 1)

  1. 用户滚动鼠标滚轮。
  2. 系统将WM_MOUSEWHEEL消息放入前台窗口线程的消息队列中。
  3. 线程的消息循环从队列中获取消息 (Application.ProcessMessage)。该消息的类型为TMsg，它有一个hwnd成员，指定消息所针对的窗口句柄。
  4. Application.OnMessage 事件被触发。
    1. 设置 Handled 参数 True 会停止进一步处理消息（后续步骤除外）。
  5. 调用 Application.IsPreProcessMessage 方法。
    1. 如果没有控件捕获鼠标，则调用获得焦点的控件的 PreProcessMessage 方法，该方法默认不执行任何操作。 VCL 中没有任何控件重写此方法。
  6. 调用 Application.IsHintMsg 方法。
    1. 活动提示窗口在重写的 IsHintMsg 方法中处理消息。无法阻止消息进一步处理。
  7. DispatchMessage 被调用。
  8. 焦点窗口的 TWinControl.WndProc 方法接收消息。此消息的类型为 TMessage，它缺少窗口（因为这是调用此方法的实例）。
  9. 调用 TWinControl.IsControlMouseMsg 方法来检查鼠标消息是否应定向到其非窗口子控件之一。
    1. 如果有子控件已捕获鼠标或位于当前鼠标位置2)，则消息将发送到子控件的 WndProc 方法，请参阅步骤 10。(2) 这永远不会发生，因为 WM_MOUSEWHEEL 包含其在屏幕坐标中的鼠标位置，并且 IsControlMouseMsg > 假定鼠标位置位于客户端坐标 (XE2) 中。）
  10. 继承的 TControl.WndProc 方法接收消息。
    1. 当系统本身不支持鼠标滚轮（CM_MOUSEWHEEL 消息并发送到 TControl.MouseWheelHandler< /code>，请参阅步骤 13。

    2. 否则消息将分派到适当的消息处理程序。

  11. TControl.WMMouseWheel 方法接收消息。
  12. WM_MOUSEWHEEL window m消息（对系统有意义，通常对 VCL 也有意义）被转换为 CM_MOUSEWHEEL 控制消息消息（仅对 VCL 有意义），它提供了方便的 VCL 的ShiftState 信息而不是系统的按键数据。
  13. 调用控件的 MouseWheelHandler 方法。
    1. 如果控件是 TCustomForm，则调用 TCustomForm.MouseWheelHandler 方法。
      1. 如果其上有焦点控件，则将 CM_MOUSEWHEEL 发送到焦点控件，请参阅步骤 14。
      2. 否则将调用继承的方法，请参阅步骤 13.2。
    2. 否则将调用 TControl.MouseWheelHandler 方法。
      1. 如果有一个控件已捕获鼠标并且没有父控件3)，则消息将发送到该控件，请参阅步骤 8 或 10，具体取决于控件的类型。 (3) 这种情况永远不会发生，因为 Capture 是通过 GetCaptureControl 获取的，它会检查 Parent <>无（XE2）。）
      2. 如果控件位于窗体上，则调用控件窗体的 MouseWheelHandler，请参阅步骤 13.1。
      3. 否则，或者如果控件是表单，则将 CM_MOUSEWHEEL 发送到控件，请参阅步骤 14。
  14. TControl.CMMouseWheel 方法接收该消息。
    1. 调用 TControl.DoMouseWheel 方法。
      1. OnMouseWheel 事件被触发。
      2. 如果未处理，则根据滚动方向调用 TControl.DoMouseWheelDown 或 TControl.DoMouseWheelUp。
      3. OnMouseWheelDown 或 OnMouseWheelUp 事件被触发。
    2. 如果不处理，则将CM_MOUSEWHEEL发送到父控件，请参见步骤14。（我相信这违背了MSDN在上面引用中给出的建议，但这无疑是一个深思熟虑的决定可能是由开发人员制作的。）

备注、观察和注意事项

在这个处理消息链中的几乎每一步都可以通过不执行任何操作来忽略，通过更改消息参数来更改，通过对其进行操作来处理，并通过设置 Handled := True 或设置 Message.Result 为非零来取消。

仅当某个控件具有焦点时，应用程序才会收到此消息。但即使当 Screen.ActiveCustomForm.ActiveControl 被强制设置为 nil 时，VCL 也会通过 TCustomForm.SetWindowFocus 确保焦点控件，默认为以前活跃的形式。 （使用 Windows.SetFocus(0)，实际上永远不会发送消息。）

由于 IsControlMouseMsg 2) 中的错误，TControl 只有在捕获了鼠标后才能接收 WM_MOUSEWHEEL 消息。 这可以通过设置 Control.MouseCapture := True 手动实现，但您必须采取特别注意迅速释放该捕获，否则会产生不需要的副作用，例如需要不必要的额外单击才能完成某件事。此外，鼠标捕获 通常仅发生在鼠标按下和鼠标松开事件之间，但不一定必须应用此限制。但即使消息到达控件，它也会被发送到其 MouseWheelHandler 方法，该方法只是将其发送回表单或活动控件。因此，默认情况下，非窗口 VCL 控件永远不能对消息进行操作。我相信这是另一个错误，否则为什么所有的轮子处理都在 TControl 中实现？为此，组件编写者可能已经实现了自己的 MouseWheelHandler 方法，无论采用什么解决方案来解决这个问题，都必须注意不要破坏这种现有的自定义。

能够使用滚轮滚动的原生控件，例如TMemo、TListBox、TDateTimePicker、TComboBox 、TTreeView、TListView等都是由系统自己滚动的。默认情况下，向此类控件发送 CM_MOUSEWHEEL 没有任何效果。这些子类控件由于 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 Eplorer 滚动聚焦的窗格，网站实现滚动行为的方式各不相同，Evernote 滚动悬停的窗口，等等...而 Delphi 的自己的 IDE 通过滚动聚焦窗口以及悬停窗口来将所有内容置于顶部，除非悬停在代码编辑器上，然后当您滚动时代码编辑器窃取焦点 (XE2)。

幸运的是，微软至少提供了用户体验指南对于基于 Windows 的桌面应用程序：

  • 使鼠标滚轮影响指针当前所在的控件、窗格或窗口。这样做可以避免出现意外结果。
  • 使鼠标滚轮在没有点击或输入焦点的情况下生效。悬停就足够了。
  • 使鼠标滚轮影响最具体范围的对象。例如，如果指针位于可滚动窗口内可滚动窗格中的可滚动列表框控件上，则鼠标滚轮会影响列表框控件。
  • 使用鼠标滚轮时请勿更改输入焦点。

所以问题中要求只滚动悬停的控件有足够的理由，但Delphi的开发人员并没有让它很容易实现。

结论和解决方案

首选解决方案是一种没有子类化窗口或针对不同窗体或控件的多种实现的解决方案。

为了防止获得焦点的控件滚动，该控件可能不会接收 CM_MOUSEWHEEL 消息。因此，任何控件的MouseWheelHandler都可能不会被调用。因此，WM_MOUSEWHEEL 可能不会发送到任何控件。因此，唯一需要干预的地方是TApplication.OnMessage。此外，消息可能无法从中逃脱，因此所有处理都应在该事件处理程序中进行，并且当绕过所有默认的 VCL 轮处理时，将考虑所有可能的情况。

让我们从简单开始吧。当前悬停的启用窗口是通过 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 我们得到了一个参考到VCL控制。如果结果为nil，则悬停的窗口不属于应用程序的进程，或者它是VCL 未知的窗口（例如下拉的TDateTimePicker）。在这种情况下，消息需要转发回 API，我们对其结果不感兴趣。

  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 检索的窗口 确保是当前进程的窗口，但不一定是VCL控件。例如，在拖动操作期间，会创建一个临时窗口（请参阅 TDragObject.DragHandle）接收鼠标消息。所有消息？不，WM_MOUSEWHEEL 没有发送到捕获窗口，所以我们必须重定向它。此外，当捕获窗口不处理该消息时，应该进行所有其他先前介绍的处理。这是 VCL 中缺少的一个功能：在拖动操作期间转动时，确实会调用 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;

这基本上完成了工作，并且它是下面介绍的单元的基础。要使其正常工作，只需将单元名称添加到项目中的 use 子句之一即可。它具有以下附加功能：

  • 可以在主窗体、活动窗体或活动控件中预览滚轮操作。
  • 注册必须调用其 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 中存在三个错误，但是，这都是基于研究文档和测试的。请测试这个单元并评论发现和错误。我对这个相当长的答案表示歉意；我根本就没有博客。

1) 厚颜无耻的命名取自A Key's Odyssey

2) 请参阅我的质量中心错误报告#135258

3) 请参阅我的质量中心错误报告#135305

Scrolling origins

An action with the mouse wheel results in a WM_MOUSEWHEEL message being sent:

Sent to the focus window when the mouse wheel is rotated. The DefWindowProc function propagates the message to the window's parent. There should be no internal forwarding of the message, since DefWindowProc propagates it up the parent chain until it finds a window that processes it.

A mouse wheel's odyssey 1)

  1. The user scrolls the mouse wheel.
  2. The system places a WM_MOUSEWHEEL message into the foreground window’s thread’s message queue.
  3. The thread’s message loop fetches the message from the queue (Application.ProcessMessage). This message is of type TMsg which has a hwnd member designating the window handle the message is ment for.
  4. The Application.OnMessage event is fired.
    1. Setting the Handled parameter True stops further processing of the message (except for the next to steps).
  5. The Application.IsPreProcessMessage method is called.
    1. If no control has captured the mouse, the focused control's PreProcessMessage method is called, which does nothing by default. No control in the VCL has overriden this method.
  6. The Application.IsHintMsg method is called.
    1. The active hint window handles the message in an overriden IsHintMsg method. Preventing the message from further processing is not possible.
  7. DispatchMessage is called.
  8. The TWinControl.WndProc method of the focused window receives the message. This message is of type TMessage which lacks the window (because that is the instance this method is called upon).
  9. The TWinControl.IsControlMouseMsg method is called to check whether the mouse message should be directed to one of its non-windowed child controls.
    1. If there is a child control that has captured the mouse or is at the current mouse position2), then the message is sent to the child control's WndProc method, see step 10. (2) This will never happen, because WM_MOUSEWHEEL contains its mouse position in screen coordinates and IsControlMouseMsg assumes a mouse position in client coordinates (XE2).)
  10. The inherited TControl.WndProc method receives the message.
    1. When the system does not natively supports mouse wheel (< Win98 or < WinNT4.0), the message is converted to a CM_MOUSEWHEEL message and is send to TControl.MouseWheelHandler, see step 13.
    2. Otherwise the message is dispatched to the appropriate message handler.
  11. The TControl.WMMouseWheel method receives the message.
  12. The WM_MOUSEWHEEL window message (meaningful to the system and often to the VCL too) is converted to a CM_MOUSEWHEEL control message (meaningful only to the VCL) which provides for the convenient VCL's ShiftState information instead of the system's keys data.
  13. The control's MouseWheelHandler method is called.
    1. If the control is a TCustomForm, then the TCustomForm.MouseWheelHandler method is called.
      1. If there is a focused control on it, then CM_MOUSEWHEEL is sent to the focused control, see step 14.
      2. Otherwise the inherited method is called, see step 13.2.
    2. Otherwise the TControl.MouseWheelHandler method is called.
      1. If there is a control that has captured the mouse and has no parent3), then the message is sent to that control, see step 8 or 10, depending on the type of the control. (3) This will never happen, because Capture is gotten with GetCaptureControl, which checks for Parent <> nil (XE2).)
      2. If the control is on a form, then the control's form's MouseWheelHandler is called, see step 13.1.
      3. Otherwise, or if the control ís the form, then CM_MOUSEWHEEL is sent to the control, see step 14.
  14. The TControl.CMMouseWheel method receives the message.
    1. The TControl.DoMouseWheel method is called.
      1. The OnMouseWheel event is fired.
      2. If not handled, then TControl.DoMouseWheelDown or TControl.DoMouseWheelUp is called, depending on the scroll direction.
      3. The OnMouseWheelDown or the OnMouseWheelUp event is fired.
    2. If not handled, then CM_MOUSEWHEEL is sent to the parent control, see step 14. (I believe this is against the advice given by MSDN in the quote above, but that undoubtedly is a thoughtful decision made by the developers. Possibly because that would start this very chain al over.)

Remarks, observations and considerations

At almost every step in this chain of processing the message can be ignored by doing nothing, altered by changing the message parameters, handled by acting on it, and canceled by setting Handled := True or setting Message.Result to non-zero.

Only when some control has focus, this message is received by the application. But even when Screen.ActiveCustomForm.ActiveControl is forcefully set to nil, the VCL ensures a focused control with TCustomForm.SetWindowFocus, which defaults to the previously active form. (With Windows.SetFocus(0), indeed the message is never sent.)

Due to the bug in IsControlMouseMsg 2), a TControl can only receive the WM_MOUSEWHEEL message if it has captured the mouse. This can manually be achieved by setting Control.MouseCapture := True, but you have to take special care of releasing that capture expeditiously, otherwise it will have unwanted side effects like the need for an unnecessary extra click to get something done. Besides, mouse capture typically only takes place between a mouse down and a mouse up event, but this restriction does not necessarily have to be applied. But even when the message reaches the control, it is sent to its MouseWheelHandler method which just sends it back to either the form or the active control. Thus non-windowed VCL controls can never act on the message by default. I believe this is another bug, otherwise why would all wheel handling have been implemented in TControl? Component writers may have implemented their own MouseWheelHandler method for this very purpose, and whatever solution comes to this question, there has to be taken care of not breaking this kind of existing customization.

Native controls which are capable of scrolling with the wheel, like TMemo, TListBox, TDateTimePicker, TComboBox, TTreeView, TListView, etc. are scrolled by the system itself. Sending CM_MOUSEWHEEL to such a control has no effect by default. These subclassed controls scroll as a result of the WM_MOUSEWHEEL message sent to the with the subclass associated API window procedure with CallWindowProc, which the VCL takes care of in TWinControl.DefaultHandler. Oddly enough, this routine does not check Message.Result before calling CallWindowProc, and once the message is sent, scrolling cannot be prevented. The message comes back with its Result set depending on whether the control normally is capable of scrolling or on the type of control. (E.g. a TMemo returns <> 0, and TEdit returns 0.) Whether it actually scrolled has no influence on the message result.

VCL controls rely on the default handling as implemented in TControl and TWinControl, as layed out above. They act on wheel events in DoMouseWheel, DoMouseWheelDown or DoMouseWheelUp. For as far I know, no control in the VCL has overriden MouseWheelHandler in order to handle wheel events.

Looking at different applications, there seems to be no conformity on which wheel scroll behaviour is the standard. For example: MS Word scrolls the page that is hovered, MS Excel scrolls the workbook that is focused, Windows Eplorer scrolls the focused pane, websites implement scroll behaviour each very differently, Evernote scrolls the window that is hovered, etc... And Delphi's own IDE tops everything by scrolling the focused window as well as the hovered window, except when hovering the code editor, then the code editor steals focus when you scroll (XE2).

Luckily Microsoft offers at least user experience guidelines for Windows-based desktop applications:

  • Make the mouse wheel affect the control, pane, or window that the pointer is currently over. Doing so avoids unintended results.
  • Make the mouse wheel take effect without clicking or having input focus. Hovering is sufficient.
  • Make the mouse wheel affect the object with the most specific scope. For example, if the pointer is over a scrollable list box control in a scrollable pane within a scrollable window, the mouse wheel affects the list box control.
  • Don't change the input focus when using the mouse wheel.

So the question's requirement to only scroll the hovered control has enough grounds, but Delphi's developers haven't made it easy to implement it.

Conclusion and solution

The preferred solution is one without subclassing windows or multiple implementations for different forms or controls.

To prevent the focused control from scrolling, the control may not receive the CM_MOUSEWHEEL message. Therefore, MouseWheelHandler of any control may not be called. Therefore, WM_MOUSEWHEEL may not be send to any control. Thus the only place left for intervention is TApplication.OnMessage. Furthermore, the message may not escape from it, so all handling should take place in that event handler and when all default VCL wheel handling is bypassed, every possible condition is to be taken care of.

Let's start simple. The enabled window which currently is hovered is gotten with 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;

With FindControl we get a reference to the VCL control. If the result is nil, then the hovered window does not belong to the application's process, or it is a window not known to the VCL (e.g. a dropped down TDateTimePicker). In that case the message needs to be forwarded back to the API, and its result we are not interested in.

  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;

When the window ís a VCL control, multiple message handlers are to be considered calling, in a specific order. When there is an enabled non-windowed control (of type TControl or descendant) on the mouse position, it first should get a CM_MOUSEWHEEL message because that control is definitely the foreground control. The message is to be constructed from the WM_MOUSEWHEEL message and translated into its VCL equivalent. Secondly, the WM_MOUSEWHEEL message has to be send to the control's DefaultHandler method to allow handling for native controls. And at last, again the CM_MOUSEWHEEL message has to be send to the control when no previous handler took care of the message. These last two steps cannot take place in reversed order because e.g. a memo on a scroll box must be able to scroll too.

  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;

When a window has captured the mouse, all wheel messages should be sent to it. The window retrieved by GetCapture is ensured to be a window of the current process, but it does not have to be a VCL control. E.g. during a drag operation, a temporary window is created (see TDragObject.DragHandle) that receives mouse messages. All messages? Noooo, WM_MOUSEWHEEL is not sent to the capturing window, so we have to redirect it. Furthermore, when the capturing window does not handle the message, all other previously covered processing should take place. This is a feature which is missing in the VCL: on wheeling during a drag operation, Form.OnMouseWheel indeed is called, but the focused or hovered control does not receive the message. This means for example that a text cannot be dragged into a memo's content on a location that is beyond the visible part of the memo.

    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;

This essentially does the job, and it was the basis for the unit presented below. To get it working, just add the unit name to one of the uses clauses in your project. It has the following additional features:

  • The possibility to preview a wheel action in the main form, the active form, or the active control.
  • Registration of control classes for which their MouseWheelHandler method has to be called.
  • The possibility to bring this TApplicationEvents object in front of all others.
  • The possibility to cancel dispatching the OnMessage event to all other TApplicationEvents objects.
  • The possibility to still allow for default VCL handling afterwards for analytical or testing purposes.

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.

Disclaimer:

This code intentionally does not scroll anything, it only prepares the message routing for VCL's OnMouseWheel* events to get the proper opportunity to get fired. This code is not tested on third-party controls. When VclHandlingAfterHandled or VclHandlingAfterUnhandled is set True, then mouse events may be fired twice. In this post I made some claims and I considered there to be three bugs in the VCL, however, that is all based on studying documentation and testing. Please do test this unit and comment on findings and bugs. I apologize for this rather long answer; I simply do not have a blog.

1) Naming cheeky taken from A Key’s Odyssey

2) See my Quality Central bug report #135258

3) See my Quality Central bug report #135305

回复 原文
黯然 2024-08-28 05:17:09

尝试像这样重写表单的 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;

Try overriding your form's MouseWheelHandler method like this (I have not tested this thoroughly):

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;
回复 原文
鹊巢 2024-08-28 05:17:09

覆盖 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;

它在这里工作正常，尽管您可能需要添加一些保护以保持
如果发生意外情况，它不会递归。

Override the TApplication.OnMessage event (or create a
TApplicationEvents component) and redirect the WM_MOUSEWHEEL message in
the event handler:

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;

It works fine here, though you may want to add some protection to keep
it from recursing if something unexpected happens.

回复 原文
晨光如昨 2024-08-28 05:17:09

您可能会发现这篇文章很有用：使用鼠标滚轮向列表框发送向下滚动消息，但列表框没有焦点[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

You might find this article useful: send a scroll down message to listbox using mousewheel, but listbox doesn't have focus [1], it is written in C#, but converting to Delphi shouldn't be too big a problem. It uses hooks to accomplish the wanted effect.

To find out which component the mouse is currently over, you can use the FindVCLWindow function, an example of this can be found in this article: Get the Control Under the Mouse in a Delphi application [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

回复 原文
清泪尽 2024-08-28 05:17:09

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

  1. 在forms<之后将amMouseWheel添加到表单单元的实现部分的uses子句中 /code> 单位： 

    单元MyUnit；

界面

用途
  Windows、消息、SysUtils、类、图形、控件、表单、
  // 鼠标滚轮的修复和实用程序
  am鼠标滚轮；
...

  2. 将以下代码保存到amMouseWheel.pas：

    单元 amMouseWheel;

// ------------------------------------------------ ----------------------------
// 原作者是 Anders Melander，[email protected]，http: //melander.dk
// 版权所有 © 2008 安德斯·梅兰德
// ------------------------------------------------ ----------------------------
// 执照：
// 知识共享署名-相同方式共享 3.0 未移植
// http://creativecommons.org/licenses/by-sa/3.0/
// ------------------------------------------------ ----------------------------

界面

用途
  表格，
  消息，
  课程，
  控制装置，
  视窗;

//------------------------------------------------ ------------------------------------------
//
// TForm 解决鼠标滚轮消息问题
//
//------------------------------------------------ ------------------------------------------
// 该类的目的是在控件上启用鼠标滚轮消息
// 没有焦点。
//
// 要使用鼠标滚动，只需将鼠标悬停在目标控件上即可
// 滚动鼠标滚轮。
//------------------------------------------------ ------------------------------------------
类型
  TForm = 类(Forms.TForm)
  民众
    procedure MouseWheelHandler(var Msg: TMessage);覆盖；
  结尾;

//------------------------------------------------ ------------------------------------------
//
// 鼠标滚轮消息的通用控制解决方法
//
//------------------------------------------------ ------------------------------------------
// 从控件（例如 TFrame）的 DoMouseWheel 方法调用此函数，例如
// 这：
//
// 函数 TMyFrame.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
// MousePos: TPoint): Boolean;
// 开始
// Result := ControlDoMouseWheel(Self, Shift, WheelDelta, MousePos) 或继承；
// 结尾;
//
//------------------------------------------------ ------------------------------------------
函数 ControlDoMouseWheel(Control: TControl; Shift: TShiftState;
  WheelDelta：整数； MousePos: TPoint): 布尔值；

执行

用途
  类型；

过程 TForm.MouseWheelHandler(var Msg: TMessage);
变量
  目标：TControl；
开始
  // 找到鼠标下的控件
  目标 := FindDragTarget(SmallPointToPoint(TCMMouseWheel(Msg).Pos), False);

  while (Target <> nil) do
  开始
    // 如果目标控件是焦点控件，那么我们将作为焦点中止
    // 控制是调用此方法的发起者。
    if (Target = Self) or ((Target is TWinControl) and (TWinControl(Target).Focused)) then
    开始
      目标：=零；
      休息;
    结尾;

    // 让目标控件处理滚动。如果控件不处理
    // 滚动然后...
    Msg.Result := Target.Perform(CM_MOUSEWHEEL, Msg.WParam, Msg.LParam);
    if (Msg.Result <> 0) then
      休息;

    // ...让目标的父级尝试一下。
    目标 := 目标.父级;
  结尾;

  // 如果鼠标下没有任何控件，则回退到默认处理
  // 可以处理滚动。
  如果（目标=零）那么
    遗传;
结尾;

类型
  TControlCracker = 类(TControl);

函数 ControlDoMouseWheel(Control: TControl; Shift: TShiftState;
  WheelDelta：整数； MousePos: TPoint): 布尔值；
变量
  目标：TControl；
开始
  (*
  ** 该方法的目的是在控件上启用鼠标滚轮消息
  ** 没有焦点。
  **
  ** 要使用鼠标滚动，只需将鼠标悬停在目标控件上，然后
  ** 滚动鼠标滚轮。
  *)
  结果：=假；

  // 找到鼠标下的控件
  目标 := FindDragTarget(MousePos, False);

  while (not Result) 和 (Target <> nil) do
  开始
    // 如果目标控件是焦点控件，那么我们将作为焦点中止
    // 控制是调用此方法的发起者。
    if (Target = Control) or ((Target is TWinControl) and (TWinControl(Target).Focused)) then
      休息;

    // 让目标控件处理滚动。如果控件不处理
    // 滚动然后...
    结果 := TControlCracker(Target).DoMouseWheel(Shift, WheelDelta, MousePos);

    // ...让目标的父级尝试一下。
    目标 := 目标.父级;
  结尾;
结尾;

结尾。

This is the solution I've been using:

  1. 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;
...

  2. Save the following code to amMouseWheel.pas:

    unit amMouseWheel;

// -----------------------------------------------------------------------------
// The original author is Anders Melander, [email protected], 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.
回复 原文
帥小哥 2024-08-28 05:17:09

我遇到了同样的问题，并通过一些小技巧解决了它，但它有效。

我不想搞乱消息，决定只调用 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，则聚焦控件将会处理，这似乎是相当足够的行为。

I had the same problem and solved it with some little hack, but it works.

I didn't want to mess around with messages and decided just to call DoMouseWheel method to control I need. Hack is that DoMouseWheel is protected method and therefore not accessible from form unit file, that's why I defined my class in form unit:

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

Then I wrote TForm1.onMouseWheel event handler:

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;

As you see, it search for all the controls on form, not only immediate children, and turns out to search from parents to children. It would be better (but more code) to make recursive search at children, but code above works just fine.

To make only one control respond to mousewheel event, you should always set Handled:=true when it's implemented. If for example you have listbox inside panel, then panel will execute DoMouseWheel first, and if it didn't handle event, listbox.DoMouseWheel will execute. If no control under mouse cursor handled DoMouseWheel, the focused control will, it seems rather adequate behavior.

回复 原文
人事已非 2024-08-28 05:17:09

仅适用于 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控件，则执行->发送消息

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

Only for using with DevExpress controls

It works on XE3. It was not tested on other versions.

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;

if you don't use DevExpress controls, then Perform -> SendMessage

SendMessage(LControl.Handle, AMsg.message, AMsg.WParam, AMsg.lParam);
回复 原文
庆幸我还是我 2024-08-28 05:17:09

在每个可滚动控件的 OnMouseEnter 事件中添加对 SetFocus 的相应调用，

因此对于 ListBox1：

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

这是否达到了预期的效果？

In the OnMouseEnter event for each scrollable control add a respective call to SetFocus

So for ListBox1:

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

Does this achieve the desired effect?

回复 原文
~没有更多了~

关于作者

勿忘初心

暂无简介

0 文章
0 评论
24 人气
发私信

相关话题

更多

热门标签

操作系统 程序设计 IT运维 Linux系统管理 JavaScript 服务器应用 solaris C/C++ PHP Shell BSD Vue.js aix Oracle Python HTML 系统管理 HTML5 CSS 前端
更多

推荐作者

胡图图

文章 0 评论 0

zt006

文章 0 评论 0

z祗昰~

文章 0 评论 0

冰葑

文章 0 评论 0

野の

文章 0 评论 0

天空

文章 0 评论 0

更多

友情链接

文江博客
    我们使用 Cookies 和其他技术来定制您的体验包括您的登录状态等。通过阅读我们的 隐私政策 了解更多相关信息。 单击 接受 或继续使用网站，即表示您同意使用 Cookies 和您的相关数据。
    原文