How to add mouse wheel support to a component desc

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.

回答1:

TGraphicControl descends from TControl, which already has mouse-wheel support. See the wm_MouseWheel message, the DoMouseWheel, DoMouseWheelDown, DoMouseWheelUp, and MouseWheelHandler methods, and the WheelAccumulator property.

回答2:

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.

回答3:

Only TWinControl descendants can receive mouse wheel messages. TGraphicControl is not a Window based control and therefore can not. It could work if the VCL routes the messages to the TGraphicControl, but apparently does not. You could descend from TCustomControl and then it would work.

回答4:

I have the same problem. No luck finding solution yet, but maybe this will be helpful:

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. "

As a new user I can not post a link to the full thread.

EDITED

If you create your component as a descendant from TCustomControl you can solve your problem as described below:

Use OnMouseEnter event to detect when mouse enters your component.
In OnMouseEnter call SetFocus method to make your component focused. Now your component can receive WM_MOUSEWHEEL message

回答5:

Trap the WM_MOUSEWHEEL message.