Из-за нескольких конструкций VCL (независимо от того, являются ли они преднамеренными вариантами реализации или могут быть ошибки 1) , я оставляю в середине) только сфокусированный элемент управления и все его родители также получают сообщения колеса мыши. как элемент управления, у которого захвачена мышь и имеет сфокусированного родителя.
На уровне 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, в противном случае элемент управления с фокусировкой также будет прокручиваться.
См. Также Как направить ввод колеса мыши для управления под курсором вместо фокусировки? для получения дополнительной информации об управлении колесом мыши и более общего решения.
1) См. Центральный отчет об ошибках качества # 135258 и Центральный отчет об ошибках качества # 135305 .