Index: lcl/controls.pp =================================================================== --- lcl/controls.pp (revision 15308) +++ lcl/controls.pp (working copy) @@ -826,6 +826,9 @@ FOnMouseLeave: TNotifyEvent; FOnMouseMove: TMouseMoveEvent; FOnMouseUp: TMouseEvent; + FOnMouseWheel: TMouseWheelEvent; + FOnMouseWheelDown: TMouseWheelUpDownEvent; + FOnMouseWheelUp: TMouseWheelUpDownEvent; FOnQuadClick: TNotifyEvent; FOnResize: TNotifyEvent; FOnShowHint: TControlShowHintEvent; @@ -983,6 +986,7 @@ procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP; procedure WMRButtonUp(var Message: TLMRButtonUp); message LM_RBUTTONUP; procedure WMMButtonUp(var Message: TLMMButtonUp); message LM_MBUTTONUP; + procedure WMMouseWheel(var Message: TLMMouseEvent); message LM_MOUSEWHEEL; procedure WMMove(var Message: TLMMove); message LM_MOVE; procedure WMSize(var Message: TLMSize); message LM_SIZE; procedure WMWindowPosChanged(var Message: TLMWindowPosChanged); message LM_WINDOWPOSCHANGED; @@ -1107,6 +1111,9 @@ property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp; property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter; property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave; + property OnMouseWheel: TMouseWheelEvent read FOnMouseWheel write FOnMouseWheel; + property OnMouseWheelDown: TMouseWheelUpDownEvent read FOnMouseWheelDown write FOnMouseWheelDown; + property OnMouseWheelUp: TMouseWheelUpDownEvent read FOnMouseWheelUp write FOnMouseWheelUp; property OnStartDock: TStartDockEvent read FOnStartDock write FOnStartDock; property OnStartDrag: TStartDragEvent read FOnStartDrag write FOnStartDrag; property OnEditingDone: TNotifyEvent read FOnEditingDone write FOnEditingDone; @@ -1258,6 +1265,9 @@ property OnClick: TNotifyEvent read FOnClick write FOnClick stored IsOnClickStored; property OnResize: TNotifyEvent read FOnResize write FOnResize; property OnShowHint: TControlShowHintEvent read FOnShowHint write FOnShowHint; + function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; dynamic; + function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; dynamic; + function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; dynamic; property Parent: TWinControl read FParent write SetParent; property PopupMenu: TPopupmenu read GetPopupmenu write SetPopupMenu; property ShowHint: Boolean read FShowHint write SetShowHint stored IsShowHintStored default False; @@ -1509,9 +1519,6 @@ FOnKeyDown: TKeyEvent; FOnKeyPress: TKeyPressEvent; FOnKeyUp: TKeyEvent; - FOnMouseWheel: TMouseWheelEvent; - FOnMouseWheelDown: TMouseWheelUpDownEvent; - FOnMouseWheelUp: TMouseWheelUpDownEvent; FOnEnter: TNotifyEvent; FOnExit: TNotifyEvent; FOnUnDock: TUnDockEvent; @@ -1599,7 +1606,6 @@ procedure WMShowWindow(var Message: TLMShowWindow); message LM_SHOWWINDOW; procedure WMEnter(var Message: TLMEnter); message LM_ENTER; procedure WMExit(var Message: TLMExit); message LM_EXIT; - procedure WMMouseWheel(var Message: TLMMouseEvent); message LM_MOUSEWHEEL; procedure WMKeyDown(var Message: TLMKeyDown); message LM_KEYDOWN; procedure WMSysKeyDown(var Message: TLMKeyDown); message LM_SYSKEYDOWN; procedure WMKeyUp(var Message: TLMKeyUp); message LM_KEYUP; @@ -1641,10 +1647,6 @@ // mouse and keyboard procedure DoEnter; dynamic; procedure DoExit; dynamic; - function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; - MousePos: TPoint): Boolean; dynamic; - function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; dynamic; - function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; dynamic; function DoKeyDownBeforeInterface(var Message: TLMKey): Boolean; function DoRemainingKeyDown(var Message: TLMKeyDown): Boolean; function DoRemainingKeyUp(var Message: TLMKeyDown): Boolean; @@ -1733,9 +1735,6 @@ property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown; property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress; property OnKeyUp: TKeyEvent read FOnKeyUp write FOnKeyUp; - property OnMouseWheel: TMouseWheelEvent read FOnMouseWheel write FOnMouseWheel; - property OnMouseWheelDown: TMouseWheelUpDownEvent read FOnMouseWheelDown write FOnMouseWheelDown; - property OnMouseWheelUp: TMouseWheelUpDownEvent read FOnMouseWheelUp write FOnMouseWheelUp; property OnUnDock: TUnDockEvent read FOnUnDock write FOnUnDock; property OnUTF8KeyPress: TUTF8KeyPressEvent read FOnUTF8KeyPress write FOnUTF8KeyPress; property ParentCtl3D: Boolean read FParentCtl3D write SetParentCtl3d default True; Index: lcl/extctrls.pp =================================================================== --- lcl/extctrls.pp (revision 15308) +++ lcl/extctrls.pp (working copy) @@ -537,6 +537,9 @@ property OnMouseUp; property OnMouseEnter; property OnMouseLeave; + property OnMouseWheel; + property OnMouseWheelDown; + property OnMouseWheelUp; property OnPaint; property OnResize; // property OnStartDock; Index: lcl/include/control.inc =================================================================== --- lcl/include/control.inc (revision 15308) +++ lcl/include/control.inc (working copy) @@ -1630,6 +1630,45 @@ MouseUp(Button, KeysToShiftState(Keys), XPos, YPos); end; +{------------------------------------------------------------------------------ + TControl DoMouseWheel "Event Handler" + ------------------------------------------------------------------------------} +function TControl.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; + MousePos: TPoint): Boolean; +begin + Result := False; + + if Assigned(FOnMouseWheel) + then FOnMouseWheel(Self, Shift, WheelDelta, MousePos, Result); + + if not Result + then begin + if WheelDelta < 0 + then Result := DoMouseWheelDown(Shift, MousePos) + else Result := DoMouseWheelUp(Shift, MousePos); + end; +end; + +{------------------------------------------------------------------------------ + TControl DoMouseWheelDown "Event Handler" +------------------------------------------------------------------------------} +function TControl.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; +begin + Result := False; + if Assigned(FOnMouseWheelDown) then + FOnMouseWheelDown(Self, Shift, MousePos, Result); +end; + +{------------------------------------------------------------------------------ + TControl DoMouseWheelUp "Event Handler" +------------------------------------------------------------------------------} +function TControl.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; +begin + Result := False; + if Assigned(FOnMouseWheelUp) then + FOnMouseWheelUp(Self, Shift, MousePos, Result); +end; + procedure TControl.SetAnchorSideIndex(Index: integer; const AValue: TAnchorSide ); begin @@ -2018,6 +2057,33 @@ end; {------------------------------------------------------------------------------ + Method: TControl.WMMouseWheel + Params: Msg: The message + Returns: nothing + + event handler. + ------------------------------------------------------------------------------} +procedure TControl.WMMouseWheel(var Message: TLMMouseEvent); +var + MousePos: TPoint; + RealControl: TControl; +begin + Assert(False, Format('Trace: [TControl.LMMouseWheel] %s', [ClassName])); + + MousePos.X := Message.X; + MousePos.Y := Message.Y; + + RealControl:=FindLCLControl(MousePos); + if not Assigned(RealControl) then RealControl:=Self; + + if RealControl.DoMouseWheel(Message.State, Message.WheelDelta, MousePos) then + Message.Result := 1 + else + inherited; +end; + + +{------------------------------------------------------------------------------ TControl Click ------------------------------------------------------------------------------} procedure TControl.Click; Index: lcl/include/wincontrol.inc =================================================================== --- lcl/include/wincontrol.inc (revision 15308) +++ lcl/include/wincontrol.inc (working copy) @@ -5389,45 +5389,6 @@ end; {------------------------------------------------------------------------------ - TWinControl DoMouseWheel "Event Handler" - ------------------------------------------------------------------------------} -function TWinControl.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; - MousePos: TPoint): Boolean; -begin - Result := False; - - if Assigned(FOnMouseWheel) - then FOnMouseWheel(Self, Shift, WheelDelta, MousePos, Result); - - if not Result - then begin - if WheelDelta < 0 - then Result := DoMouseWheelDown(Shift, MousePos) - else Result := DoMouseWheelUp(Shift, MousePos); - end; -end; - -{------------------------------------------------------------------------------ - TWinControl DoMouseWheelDown "Event Handler" -------------------------------------------------------------------------------} -function TWinControl.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; -begin - Result := False; - if Assigned(FOnMouseWheelDown) then - FOnMouseWheelDown(Self, Shift, MousePos, Result); -end; - -{------------------------------------------------------------------------------ - TWinControl DoMouseWheelUp "Event Handler" -------------------------------------------------------------------------------} -function TWinControl.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; -begin - Result := False; - if Assigned(FOnMouseWheelUp) then - FOnMouseWheelUp(Self, Shift, MousePos, Result); -end; - -{------------------------------------------------------------------------------ TWinControl Insert ------------------------------------------------------------------------------} procedure TWinControl.Insert(AControl : TControl); @@ -6361,28 +6322,6 @@ end; {------------------------------------------------------------------------------ - Method: TWinControl.WMMouseWheel - Params: Msg: The message - Returns: nothing - - event handler. - ------------------------------------------------------------------------------} -procedure TWinControl.WMMouseWheel(var Message: TLMMouseEvent); -var - MousePos : TPoint; -begin - Assert(False, Format('Trace: [TWinControl.LMMouseWheel] %s', [ClassName])); - - MousePos.X := Message.X; - MousePos.Y := Message.Y; - - if DoMouseWheel(Message.State, Message.WheelDelta, MousePos) then - Message.Result := 1 - else - inherited; -end; - -{------------------------------------------------------------------------------ Method: TWinControl.WMChar Params: Msg: The message Returns: nothing