delphi - How to add mouse wheel support to a component descended from TGraphicControl?

Question

I have created a delphi component which descends from TGraphicControl. Is it possible to add support for mouse wheels?

--- Edit ---

I've exposed the MouseWheel events as shown below but they aren't called.

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

--- Edit ---

As suggested below, I've tried to trap the WM_MOUSEWHEEL and CM_MOUSEWHEEL messages, but it doesn't seem to work. However I've managed to trap the CM_MOUSEENTER message. I don't understand why i can trap one type of message, but not the other.

Answer 1

Due to several VCL constructs (whether they are deliberate implementation choices or may possibly be bugs¹⁾, I leave in the middle) only the focused control and all its parents get mouse wheel messages, as well as the control which has the mouse captured ánd has a focused parent.

At the TControl level, the latter condition can be enforced. A control receives a CM_MOUSEENTER message from the VCL when the mouse enters the client space of the control. To force it to receive mouse wheel messages, focus its parent and capture the mouse in that message handler:

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

But these settings must be undone when the mouse exits the control. Since the control is now capturing the mouse, CM_MOUSELEAVE is not received by it, so you have to manually check this, for example in the WM_MOUSEMOVE message handler:

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;

Now, you would assume the wheel messages received by the control will subsequently fire the OnMouseWheel, OnMouseWheelDown and OnMouseWheelUp events. But noooo, one more intervention is needed. The message enters the control in MouseWheelHandler which happens to pass the message on to either the form or active control. To get these events fired, a CM_MOUSEWHEEL control message should be sent:

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;

Which results in this final code:

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.

As you see, this changes the focused control, which is against the user experience guidelines for Windows-based desktop applications and might result in visual distractions when the focused control had an explicit focused state.

As an alternative, you can bypass all default VCL mouse wheel handling by overriding Application.OnMessage and deal with it there. This might be done as follows:

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.

Be careful to set the Handled parameter of the MouseWheel* event to True, otherwise the focused control will scroll as well.

See also How to direct the mouse wheel input to control under cursor instead of focused? for more background on mouse wheel handling and a more general solution.

¹⁾ See Quality Central bug report #135258, and Quality Central bug report #135305.