41

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

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

4

8 回答 8

26

滚动起源

使用鼠标滚轮的操作会导致发送一条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. 当系统原生不支持鼠标滚轮（<Win98或<WinNT4.0）时，将消息转换为CM_MOUSEWHEEL消息发送到TControl.MouseWheelHandler，见步骤13。
    2. 否则，消息将被分派给适当的消息处理程序。
  11. 该TControl.WMMouseWheel方法接收消息。
  12. 窗口消息（对系统有意义，通常对WM_MOUSEWHEEL VCL也有意义）被转换为控制消息（仅对VCL有意义），它提供方便的 VCL信息而不是系统的密钥数据。CM_MOUSEWHEEL ShiftState
  13. 调用控件的MouseWheelHandler方法。
    1. 如果控件是 a TCustomForm，则TCustomForm.MouseWheelHandler调用该方法。
      1. 如果上面有焦点控件，则CM_MOUSEWHEEL发送到焦点控件，参见步骤 14。
      2. 否则调用继承的方法，参见步骤 13.2。
    2. 否则TControl.MouseWheelHandler调用该方法。
      1. 如果有一个控件已捕获鼠标并且没有父控件3)，则消息将发送到该控件，请参见步骤 8 或 10，具体取决于控件的类型。( 3)这永远不会发生，因为Capture是用 得到的GetCaptureControl，它检查Parent <> nil(XE2)。)
      2. 如果控件位于窗体上，则MouseWheelHandler调用控件的窗体，请参见步骤 13.1。
      3. 否则，或者如果控件是表单，则将CM_MOUSEWHEEL其发送到控件，请参见步骤 14。
  14. 该TControl.CMMouseWheel方法接收消息。
    1. 该TControl.DoMouseWheel方法被调用。
      1. 事件OnMouseWheel被触发。
      2. 如果未处理，则调用TControl.DoMouseWheelDownor 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)中的 bug ，aTControl只能在WM_MOUSEWHEEL捕获到鼠标后才能接收到消息。这可以通过设置手动实现Control.MouseCapture := True，但是您必须特别注意迅速释放该捕获，否则它会产生不必要的副作用，例如需要不必要的额外点击才能完成某事。此外，鼠标捕获通常只发生在鼠标按下和鼠标抬起事件之间，但不一定必须应用此限制。但是即使当消息到达控件时，它也会被发送到它的MouseWheelHandler方法只是将其发送回表单或活动控件。因此，默认情况下，非窗口 VCL 控件永远不会对消息起作用。我相信这是另一个错误，否则为什么所有车轮处理都已实施TControl？组件编写者可能已经为此目的实现了自己的MouseWheelHandler方法，无论解决这个问题，都必须注意不要破坏这种现有的定制。

能够使用滚轮滚动的本机控件TMemo，如、TListBox、TDateTimePicker、TComboBox、TTreeView、TListView等，由系统本身滚动。默认情况下，发送CM_MOUSEWHEEL到此类控件无效。这些子类控件滚动作为WM_MOUSEWHEEL消息发送到与子类关联的 API 窗口过程的结果CallWindowProc，VCL 负责处理TWinControl.DefaultHandler。Message.Result奇怪的是，这个例程在调用 之前不检查CallWindowProc，一旦消息发送，就无法阻止滚动。Result根据控件是否通常能够滚动或控件的类型，该消息将返回其设置。（例如，TMemo返回<> 0和TEdit返回0.) 是否实际滚动对消息结果没有影响。

VCL 控件依赖于在TControl和中实现的默认处理TWinControl，如上所示。它们作用于或中DoMouseWheel的车轮事件。据我所知，VCL 中的任何控件都没有被覆盖以处理车轮事件。DoMouseWheelDownDoMouseWheelUpMouseWheelHandler

查看不同的应用程序，似乎没有一致的滚轮滚动行为是标准。例如：MS Word 滚动悬停的页面，MS Excel 滚动聚焦的工作簿，Windows Eplorer 滚动聚焦的窗格，网站实现的滚动行为各不相同，Evernote 滚动悬停的窗口，等等……还有 Delphi 的自己的 IDE 通过滚动焦点窗口和悬停窗口来使所有内容居于首位，除非悬停代码编辑器，然后代码编辑器会在您滚动时窃取焦点（XE2）。

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

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

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

结论和解决方案

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

为了防止焦点控件滚动，控件可能不会收到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）。所有消息？Noooo，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;

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

  • 在主窗体、活动窗体或活动控件中预览滚轮动作的可能性。
  • 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)请参阅我的Quality Central 错误报告 #135258

3)请参阅我的Quality Central 错误报告 #135305

于 2015-12-20T22:41:42.303 回答
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;
于 2010-02-12T12:07:54.497 回答
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;

它在这里工作得很好，尽管你可能想要添加一些保护以防止它在发生意外情况时重复发生。

于 2010-02-12T12:59:28.080 回答
2

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

要找出鼠标当前位于哪个组件上，可以使用 FindVCLWindow 函数，可以在本文中找到一个示例：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

于 2010-02-12T11:14:25.410 回答
2

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

  1. 在单元之后添加到amMouseWheel表单单元的实现部分的使用子句：forms

    unit MyUnit;

interface

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

  2. 将以下代码保存到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.
于 2014-02-24T09:32:57.020 回答
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，则焦点控件将，这似乎是相当适当的行为。

于 2015-12-07T14:14:51.173 回答
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);
于 2016-11-05T06:06:25.330 回答
-2

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

所以对于 ListBox1：

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

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

于 2010-02-12T16:18:09.327 回答