paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-06 18:58:12 +02:00
Code Issues Packages Projects Releases Wiki Activity

TUpDown: use the MouseEnter/MouseLeave methods to fire the OnMouseEnter and OnMouseLeave events. Slightly alters r64151 #6a41fe9801.

Browse Source 
git-svn-id: trunk@64369 -
This commit is contained in:
bart 2021-01-09 21:45:16 +00:00
parent 25f463a798
commit cdfd1ae57a
2 changed files with 24 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
lcl/comctrls.pp
View File

@ -1904,8 +1904,8 @@ type
FThousands: Boolean;
FWrap: Boolean;
FUseWS: Boolean;
procedure CheckMouseEntering;
procedure CheckMouseLeaving;
function CheckMouseEntering: Boolean;
function CheckMouseLeaving: Boolean;
function GetPosition: SmallInt;
procedure BTimerExec(Sender : TObject);
function GetFlat: Boolean;

38
lcl/include/customupdown.inc
View File

@ -53,14 +53,14 @@ end;
procedure TUpDownButton.MouseEnter;
begin
FUpDown.CheckMouseEntering;
inherited MouseEnter;
inherited MouseEnter; //does UpdateState o.a., so call this as well
FUpDown.MouseEnter;
end;
procedure TUpDownButton.MouseLeave;
begin
FUpDown.CheckMouseLeaving;
inherited MouseLeave;
inherited MouseLeave; //does UpdateState o.a., so call this as well
FUpDown.MouseLeave;
end;
procedure TUpDownButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
@ -539,11 +539,21 @@ begin
end;
procedure TCustomUpDown.MouseEnter;
begin // This should never happen because buttons cover the whole component.
begin
if CheckMouseEntering then
begin
inherited MouseEnter;
FMouseInsideComp := True;
end;
end;
procedure TCustomUpDown.MouseLeave;
begin // This should never happen because buttons cover the whole component.
begin
if CheckMouseLeaving then
begin
inherited MouseLeave;
FMouseInsideComp := False;
end;
end;
procedure TCustomUpDown.DoSetBounds(ALeft, ATop, AWidth, AHeight: integer);
@ -592,26 +602,22 @@ begin
SetAssociate(nil);
end;
procedure TCustomUpDown.CheckMouseEntering;
function TCustomUpDown.CheckMouseEntering: Boolean;
// Mouse in entering this control.
begin
if FMouseInsideComp then Exit; // Already inside, moving between 2 buttons.
inherited MouseEnter;
FMouseInsideComp := True;
//debugln(['TCustomUpDown.CheckMouseEntering: FMouseInsideComp=',FMouseInsideComp]);
Result := not FMouseInsideComp;
end;
procedure TCustomUpDown.CheckMouseLeaving;
function TCustomUpDown.CheckMouseLeaving: Boolean;
// Mouse in leaving this control.
var
P: TPoint;
begin
GetCursorPos(P);
P:=ScreenToClient(P);
if PtInRect(ClientRect, P) then
exit; // Still inside, moving between 2 buttons.
Assert(FMouseInsideComp, 'TCustomUpDown.DecMouseEnterLeaveCnt: FMouseInsideComp=False');
FMouseInsideComp := False;
inherited MouseLeave;
Result := not PtInRect(ClientRect, P);
//debugln(['TCustomUpDown.CheckMouseLeaving: PtInRect(ClientRect, P)=',PtInRect(ClientRect, P)]);
end;
function TCustomUpDown.GetPosition: SmallInt;