Как направить вход колеса мыши на управление под курсором вместо сфокусированного?

Я использую несколько элементов управления прокруткой: TTreeViews, TListViews, DevExpress cxGrids и cxTreeLists и т.д. Когда колесико мыши вращается, управление с фокусом получает вход, независимо от того, какой контроль над курсором мыши завершен.

Как вы управляете вводом колесика мыши в любое управление курсором мыши? В этом отношении Delphi IDE работает очень хорошо.

Ответы

Ответ 1

Попробуйте переопределить метод формы 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;

Ответ 2

Прокрутка источника

Действие с колесом мыши приводит к сообщению WM_MOUSEWHEEL:

Отправлено в окно фокуса, когда колесико мыши повернуто. Функция DefWindowProc передает сообщение родительскому окну. Не должно быть внутренней пересылки сообщения, так как DefWindowProc распространяет его на родительскую цепочку, пока не найдет окно, которое его обрабатывает.

Одиссея колесика мыши 1)

  • Пользователь прокручивает колесико мыши.
  • Система помещает сообщение WM_MOUSEWHEEL в очередь сообщений о потоках окон переднего плана.
  • Цикл сообщений потоков выбирает сообщение из очереди (Application.ProcessMessage). Это сообщение имеет тип TMsg, у которого есть член hwnd, обозначающий дескриптор окна, для которого указано сообщение.
  • Событие Application.OnMessage запускается.
    • Установка параметра Handled True останавливает дальнейшую обработку сообщения (за исключением следующих шагов).
  • Вызывается метод Application.IsPreProcessMessage.
    • Если элемент управления не захватил мышь, вызывается метод сфокусированного управления PreProcessMessage, который по умолчанию ничего не делает. Отсутствие контроля в VCL превзошло этот метод.
  • Вызывается метод Application.IsHintMsg.
    • Активное окно подсказки обрабатывает сообщение в методе overriden IsHintMsg. Предотвращение сообщения от дальнейшей обработки невозможно.
  • DispatchMessage.
  • Метод TWinControl.WndProc сфокусированного окна получает сообщение. Это сообщение имеет тип TMessage, которому не хватает окна (потому что это экземпляр, вызываемый этим методом).
  • Вызывается метод TWinControl.IsControlMouseMsg, чтобы проверить, должно ли сообщение мыши быть перенаправлено на один из его дочерних элементов управления, отличных от окон.
    • Если есть дочерний элемент управления, который захватил мышь или находится в текущей позиции мыши 2) тогда сообщение отправляется дочернему элементу управления WndProc, см. шаг 10. ( 2) Это никогда не произойдет, потому что WM_MOUSEWHEEL содержит свою позицию мыши в координатах экрана, а IsControlMouseMsg предполагает положение мыши в клиентских координатах (XE2).)
  • Наследуемый метод TControl.WndProc получает сообщение.
    • Если система не поддерживает колесико мыши (< Win98 или < WinNT4.0), сообщение преобразуется в сообщение CM_MOUSEWHEEL и отправляется на TControl.MouseWheelHandler, см. шаг 13.
    • В противном случае сообщение отправляется соответствующему обработчику сообщений.
  • Метод TControl.WMMouseWheel получает сообщение.
  • WM_MOUSEWHEEL w indow m Essage (значимый для системы и часто для VCL тоже) преобразуется в CM_MOUSEWHEEL c ontrol m essage (значимый только для VCL), который обеспечивает удобную информацию VCL ShiftState вместо данные системных клавиш.
  • Вызывается метод управления MouseWheelHandler.
    • Если элемент управления имеет значение TCustomForm, тогда вызывается метод TCustomForm.MouseWheelHandler.
      • Если на нем есть сфокусированное управление, тогда CM_MOUSEWHEEL отправляется на сфокусированное управление, см. шаг 14.
      • В противном случае вызывается унаследованный метод, см. шаг 13.2.
    • В противном случае вызывается метод TControl.MouseWheelHandler.
      • Если есть элемент управления, который захватил мышь и не имеет родительского 3) тогда сообщение отправляется этому элементу управления, см. шаг 8 или 10, в зависимости от типа элемента управления. ( 3) Это никогда не произойдет, потому что Capture получен с помощью GetCaptureControl, который проверяет наличие Parent <> nil (XE2).)
      • Если элемент управления находится в форме, вызывается форма управления MouseWheelHandler, см. шаг 13.1.
      • В противном случае, или если элемент управления является формой, тогда CM_MOUSEWHEEL отправляется в элемент управления, см. шаг 14.
  • Метод TControl.CMMouseWheel получает сообщение.
    • Вызывается метод TControl.DoMouseWheel.
      • Событие OnMouseWheel запущено.
      • Если не обрабатывается, вызывается TControl.DoMouseWheelDown или TControl.DoMouseWheelUp в зависимости от направления прокрутки.
      • Выполняется событие OnMouseWheelDown или OnMouseWheelUp.
    • Если не обрабатывается, тогда 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 в такой элемент управления по умолчанию не влияет. Эти подклассифицированные элементы управления прокручиваются в результате сообщения WM_MOUSEWHEEL, отправленного с помощью связанной с подкладом процедуры окна API с помощью CallWindowProc, который VCL позаботится о TWinControl.DefaultHandler. Как ни странно, эта процедура не проверяет Message.Result перед вызовом CallWindowProc, и после отправки сообщения прокрутка не может быть предотвращена. Сообщение возвращается с набором Result, зависящим от того, может ли управление нормально прокручивать или управлять типом элемента управления. (Например, a TMemo возвращает <> 0, а TEdit возвращает 0.) Независимо от того, действительно ли он прокручивается, не влияет на результат сообщения.

Элементы управления VCL полагаются на обработку по умолчанию, реализованную в TControl и TWinControl, как описано выше. Они воздействуют на события колеса в DoMouseWheel, DoMouseWheelDown или DoMouseWheelUp. Насколько мне известно, никакой контроль в VCL не превзошел MouseWheelHandler, чтобы обрабатывать события колес.

При взгляде на разные приложения, похоже, нет соответствия, по которому поведение прокрутки колес является стандартом. Например: MS Word прокручивает страницу, которая зависает, MS Excel прокручивает рабочую книгу, которая сфокусирована, Windows Eplorer прокручивает сфокусированную панель, веб-сайты реализуют поведение прокрутки по-разному, Evernote прокручивает окно, которое зависает, и т.д.... и Delphi собственная среда IDE вершина всего, прокручивая сфокусированное окно , а также зависающее окно, за исключением того, что при зависании редактора кода, тогда редактор кода крадет фокус при прокрутке (XE2).

К счастью Microsoft предлагает как минимум рекомендации для пользователей для настольных приложений на базе Windows:

  • Сделать колесико мыши влияющим на элемент управления, панель или окно, в котором в данный момент находится указатель.. Это позволяет избежать непреднамеренных результатов.
  • Сделать колесико мыши эффектом без щелчка или с фокусом ввода. Наведение достаточно.
  • Сделать колесико мыши влияющим на объект с наиболее конкретной областью. Например, если указатель находится над элементом управления прокручиваемым списком в прокручиваемой панели в прокручиваемом окне, колесико мыши влияет на list box.
  • Не меняйте фокус ввода при использовании колеса мыши.

Таким образом, требование к запросу только для прокрутки зависающего элемента управления имеет достаточные основания, но разработчики 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), который получает сообщения мыши. Все сообщения? 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) Именование нахально взято из Одиссея ключей

2) См. мой Отчет об ошибке Quality Central # 135258

3) См. мой Отчет об ошибках в Quality Central # 135305

Ответ 3

Отмените событие 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;

Здесь хорошо работает, хотя вы можете добавить некоторую защиту, чтобы он от рекурсии, если произойдет что-то неожиданное.

Ответ 4

Вы можете найти эту статью полезной: отправить сообщение прокрутки вниз в список с помощью мыши, но в списке нет фокуса [1], он написан на С#, но преобразование в 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

Ответ 5

Это решение, которое я использовал:

  • Добавьте amMouseWheel в раздел uses раздела реализации единицы формы после блока forms:

    unit MyUnit;

interface

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

  • Сохраните следующий код 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 (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 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 parent give it a go instead.
    Target := Target.Parent;
  end;
end;

end.

Ответ 6

У меня была такая же проблема, и я решил немного взломать ее, но она работает.

Я не хотел общаться с сообщениями и решил просто вызвать метод DoMouseWheel для управления, который мне нужен. Hack заключается в том, что метод 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, то сфокусированный элемент управления будет выглядеть довольно адекватно.

Ответ 7

Только для использования с элементами управления 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

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

Ответ 8

В событии OnMouseEnter для каждого прокручиваемого элемента управления добавьте соответствующий вызов SetFocus

Итак, для ListBox1:

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

Достигает ли это желаемого эффекта?