Как добавить поддержку колеса мыши в компонент, унаследованный от TGraphicControl?

Перехватить сообщение WM_MOUSEWHEEL.

TGraphicControl происходит от TControl, в котором уже есть поддержка колесика мыши. См. Сообщение wm_MouseWheel, методы DoMouseWheel, DoMouseWheelDown, DoMouseWheelUp и MouseWheelHandler, а также свойство WheelAccumulator.

Только потомки TWinControl могут получать сообщения колесика мыши. TGraphicControl не является оконным элементом управления и поэтому не может. Это могло бы работать, если VCL направляет сообщения в TGraphicControl, но, по-видимому, нет. Вы можете спуститься с TCustomControl, и тогда все заработает.

У меня та же проблема. Пока не удалось найти решение, но, возможно, это будет полезно:

I suspect the other component is calling the Win API method SetCapture, which according to the API help:

"The SetCapture function sets the mouse capture to the specified window belonging to the current thread. Once a window has captured the mouse, all mouse input is directed to that window, regardless of whether the cursor is within the borders of that window. Only one window at a time can capture the mouse. "

Как новый пользователь, я не могу разместить ссылку на полную тему.

ИЗМЕНИТЬ

Если вы создаете свой компонент как потомок TCustomControl, вы можете решить свою проблему, как описано ниже:

1. Используйте событие OnMouseEnter, чтобы определить, когда мышь входит в ваш компонент.
2. В OnMouseEnter вызовите метод SetFocus, чтобы сфокусировать ваш компонент. Теперь ваш компонент может получать сообщение WM_MOUSEWHEEL

Из-за нескольких конструкций VCL (являются ли они преднамеренным выбором реализации или, возможно, ошибками ¹⁾, я оставляю посередине) только сфокусированный элемент управления и все его родители получают сообщения колесика мыши, а также элемент управления, который захватил мышь и имеет сосредоточенный родитель.

На уровне TControl последнее условие может быть выполнено. Элемент управления получает сообщение CM_MOUSEENTER от VCL, когда мышь входит в клиентское пространство элемента управления. Чтобы заставить его получать сообщения колесика мыши, сфокусируйте его родительский элемент и захватите мышь в этом обработчике сообщений:

procedure TWheelControl.CMMouseEnter(var Message: TMessage);
begin
  FPrevFocusWindow := SetFocus(Parent.Handle);
  MouseCapture := True;
  inherited;
end;

Но эти настройки должны быть отменены, когда мышь покидает элемент управления. Поскольку элемент управления теперь захватывает мышь, CM_MOUSELEAVE не получает, поэтому вам нужно вручную проверить это, например, в обработчике сообщений WM_MOUSEMOVE:

procedure TWheelControl.WMMouseMove(var Message: TWMMouseMove);
begin
  if MouseCapture and
    not PtInRect(ClientRect, SmallPointToPoint(Message.Pos)) then
  begin
    MouseCapture := False;
    SetFocus(FPrevFocusWindow);
  end;
  inherited;
end;

Теперь вы можете предположить, что сообщения колеса, полученные элементом управления, впоследствии вызовут события OnMouseWheel, OnMouseWheelDown и OnMouseWheelUp. Но нет, нужно еще одно вмешательство. Сообщение поступает в элемент управления в MouseWheelHandler, который передает сообщение либо форме, либо активному элементу управления. Чтобы запустить эти события, необходимо отправить управляющее сообщение CM_MOUSEWHEEL:

procedure TWheelControl.MouseWheelHandler(var Message: TMessage);
begin
  Message.Result := Perform(CM_MOUSEWHEEL, Message.WParam, Message.LParam);
  if Message.Result = 0 then
    inherited MouseWheelHandler(Message);
end;

Что приводит к этому окончательному коду:

unit WheelControl;

interface

uses
  System.Classes, Winapi.Windows, Winapi.Messages, Vcl.Controls;

type
  TWheelControl = class(TGraphicControl)
  private
    FPrevFocusWindow: HWND;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
  public
    procedure MouseWheelHandler(var Message: TMessage); override;
  published
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
  end;

implementation

{ TWheelControl }

procedure TWheelControl.CMMouseEnter(var Message: TMessage);
begin
  FPrevFocusWindow := SetFocus(Parent.Handle);
  MouseCapture := True;
  inherited;
end;

procedure TWheelControl.MouseWheelHandler(var Message: TMessage);
begin
  Message.Result := Perform(CM_MOUSEWHEEL, Message.WParam, Message.LParam);
  if Message.Result = 0 then
    inherited MouseWheelHandler(Message);
end;

procedure TWheelControl.WMMouseMove(var Message: TWMMouseMove);
begin
  if MouseCapture and
    not PtInRect(ClientRect, SmallPointToPoint(Message.Pos)) then
  begin
    MouseCapture := False;
    SetFocus(FPrevFocusWindow);
  end;
  inherited;
end;

end.

Как видите, это изменяет сфокусированный элемент управления, что противоречит руководящие принципы взаимодействия с пользователем для настольных приложений на базе Windows и может привести к визуальным отвлечениям, когда сфокусированный элемент управления имел явно сфокусированное состояние.

В качестве альтернативы вы можете обойти всю обработку колесика мыши VCL по умолчанию, переопределив Application.OnMessage и обработав это там. Это можно сделать следующим образом:

unit WheelControl2;

interface

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

type
  TWheelControl = class(TGraphicControl)
  published
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
  end;

implementation

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

procedure TWheelInterceptor.ApplicationMessage(var Msg: tagMSG;
  var Handled: Boolean);
var
  Window: HWND;
  WinControl: TWinControl;
  Control: TControl;
  Message: TMessage;
begin
  if Msg.message = WM_MOUSEWHEEL then
  begin
     Window := WindowFromPoint(Msg.pt);
     if Window <> 0 then
     begin
       WinControl := FindControl(Window);
       if WinControl <> nil then
       begin
         Control := WinControl.ControlAtPos(WinControl.ScreenToClient(Msg.pt),
           False);
         if Control <> nil then
         begin
           Message.WParam := Msg.wParam;
           Message.LParam := Msg.lParam;
           TCMMouseWheel(Message).ShiftState :=
             KeysToShiftState(TWMMouseWheel(Message).Keys);
           Message.Result := Control.Perform(CM_MOUSEWHEEL, Message.WParam,
             Message.LParam);
           Handled := Message.Result <> 0;
         end;
       end;
     end;
  end;
end;

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

initialization
  TWheelInterceptor.Create(Application);

end.

Будьте осторожны, чтобы установить для параметра Handled события MouseWheel* значение True, иначе сфокусированный элемент управления также будет прокручиваться.

См. Также Как направить ввод колеса мыши для управления под курсором, а не в фокусе? для получения дополнительной информации о работе с колесом мыши и более общем решении.

¹⁾ См. Отчет об ошибке в Центре качества # 135258 и Отчет об ошибке в Центре качества # 135305.

Я использую следующую технику: я подписываюсь на событие формы MouseWheelUp() и внутри него ищу виджет с WindowFromPoint() (функция win32 api) и Vcl.Controls.FindControl(), затем проверяю, есть ли у меня правильный виджет пользовательского интерфейса, когда нет. проверьте наличие ActiveControl (виджет в форме, который в данный момент находится в фокусе).

Этот метод гарантирует, что событие подъема / опускания колеса мыши срабатывает, когда виджет находится под курсором или когда он не под курсором, но имеет фокус.

Пример ниже реагирует на событие подъема колесика мыши и увеличивает TSpinEdit, когда TSpinEdit находится под курсором или имеет фокус.

function TFormOptionsDialog.FindSpinEdit(const AMousePos: TPoint): TSpinEdit;
var
  LWindow: HWND;
  LWinControl: TWinControl;
begin
  Result := nil;

  LWindow := WindowFromPoint(AMousePos);
  if LWindow = 0 then
    Exit;

  LWinControl := FindControl(LWindow);
  if LWinControl = nil then
    Exit;

  if LWinControl is TSpinEdit then
    Exit(LWinControl as TSpinEdit);

  if LWinControl.Parent is TSpinEdit then
    Exit(LWinControl.Parent as TSpinEdit);

  if ActiveControl is TSpinEdit then
    Exit(ActiveControl as TSpinEdit);
end;

procedure TFormOptionsDialog.FormMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint;
  var Handled: Boolean);
var
  LSpinEdit: TSpinEdit;
begin
  LSpinEdit := FindSpinEdit(MousePos);
  if LSpinEdit = nil then
    Exit;

  LSpinEdit.Value := LSpinEdit.Value + LSpinEdit.Increment;
  Handled := True;
end;