mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-09 15:48:03 +02:00
LCL: Fire TUpDown MouseEnter and MouseLeave events. Issue #38101.
git-svn-id: trunk@64151 -
This commit is contained in:
juha
parent
e994fa439c
commit
6a41fe9801
@ -1894,6 +1894,7 @@ type
|
||||
FMinRepeatInterval: Byte; //Interval starts at 300 and this must be smaller always
|
||||
FMouseDownBounds : TRect;
|
||||
FMouseTimerEvent: TProcedureOfObject; // the Min/MaxBtn's Click method
|
||||
FMouseInsideComp: Boolean; // Used for MouseEnter and MouseLeave events.
|
||||
FOnChanging: TUDChangingEvent;
|
||||
FOnChangingEx: TUDChangingEventEx;
|
||||
FOnClick: TUDClickEvent;
|
||||
@ -1902,6 +1903,8 @@ type
|
||||
FThousands: Boolean;
|
||||
FWrap: Boolean;
|
||||
FUseWS: Boolean;
|
||||
procedure CheckMouseEntering;
|
||||
procedure CheckMouseLeaving;
|
||||
function GetPosition: SmallInt;
|
||||
procedure BTimerExec(Sender : TObject);
|
||||
function GetFlat: Boolean;
|
||||
@ -1934,6 +1937,8 @@ type
|
||||
function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
|
||||
function DoMouseWheelLeft(Shift: TShiftState; MousePos: TPoint): Boolean; override;
|
||||
function DoMouseWheelRight(Shift: TShiftState; MousePos: TPoint): Boolean; override;
|
||||
procedure MouseEnter; override;
|
||||
procedure MouseLeave; override;
|
||||
procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer); override;
|
||||
procedure SetEnabled(Value: Boolean); override;
|
||||
class function GetControlClassDefaultSize: TSize; override;
|
||||
|
||||
@ -23,16 +23,14 @@ Type
|
||||
private
|
||||
procedure ButtonCoordToUpDownCoord(var X,Y: Integer);
|
||||
protected
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer
|
||||
); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
||||
override;
|
||||
procedure MouseEnter; override;
|
||||
procedure MouseLeave; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure DblClick; override;
|
||||
public
|
||||
constructor CreateWithParams(UpDown : TCustomUpDown;
|
||||
ButtonType : TUDBtnType);
|
||||
|
||||
constructor CreateWithParams(UpDown : TCustomUpDown; ButtonType : TUDBtnType);
|
||||
procedure Click; override;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
@ -53,41 +51,52 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TUpDownButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
|
||||
Y: Integer);
|
||||
procedure TUpDownButton.MouseEnter;
|
||||
begin
|
||||
FUpDown.CheckMouseEntering;
|
||||
inherited MouseEnter;
|
||||
end;
|
||||
|
||||
procedure TUpDownButton.MouseLeave;
|
||||
begin
|
||||
FUpDown.CheckMouseLeaving;
|
||||
inherited MouseLeave;
|
||||
end;
|
||||
|
||||
procedure TUpDownButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: Integer);
|
||||
begin
|
||||
inherited MouseDown(Button, Shift, X, Y);
|
||||
ButtonCoordToUpDownCoord(X, Y);
|
||||
FUpDown.MouseDown(Button, Shift, X, Y);
|
||||
if Button = mbLeft then begin
|
||||
With FUpDown do begin
|
||||
FMouseTimerEvent := @Self.Click;
|
||||
FMouseDownBounds := Bounds(Self.ClientOrigin.X, Self.ClientOrigin.Y,
|
||||
Self.Width,Self.Height);
|
||||
If Not Assigned(FMouseTimer) then
|
||||
FMouseTimer := TTimer.Create(FUpDown);
|
||||
With FMouseTimer do begin
|
||||
Enabled := False;
|
||||
Interval := 300;
|
||||
OnTimer := @BTimerExec;
|
||||
Enabled := True;
|
||||
end;
|
||||
if Button = mbLeft then
|
||||
begin
|
||||
FUpDown.FMouseTimerEvent := @Self.Click;
|
||||
FUpDown.FMouseDownBounds := Bounds(ClientOrigin.X, ClientOrigin.Y, Width, Height);
|
||||
If Not Assigned(FMouseTimer) then
|
||||
FMouseTimer := TTimer.Create(FUpDown);
|
||||
With FMouseTimer do
|
||||
begin
|
||||
Enabled := False;
|
||||
Interval := 300;
|
||||
OnTimer := @FUpDown.BTimerExec;
|
||||
Enabled := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TUpDownButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
|
||||
Y: Integer);
|
||||
procedure TUpDownButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: Integer);
|
||||
begin
|
||||
inherited MouseUp(Button, Shift, X, Y);
|
||||
ButtonCoordToUpDownCoord(X, Y);
|
||||
FUpDown.MouseUp(Button, Shift, X, Y);
|
||||
With FUpDown do
|
||||
If Assigned(FMouseTimer) then begin
|
||||
FreeAndNil(FMouseTimer);
|
||||
FMouseDownBounds := Rect(0,0,0,0);
|
||||
FMouseTimerEvent := nil;
|
||||
end;
|
||||
If Assigned(FMouseTimer) then
|
||||
begin
|
||||
FreeAndNil(FMouseTimer);
|
||||
FUpDown.FMouseDownBounds := Rect(0,0,0,0);
|
||||
FUpDown.FMouseTimerEvent := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TUpDownButton.MouseMove(Shift: TShiftState; X, Y: Integer);
|
||||
@ -104,43 +113,7 @@ end;
|
||||
|
||||
procedure TUpDownButton.Click;
|
||||
begin
|
||||
with FUpDown do
|
||||
begin
|
||||
FCanChangePos := Position;
|
||||
FCanChangeDir := updNone;
|
||||
|
||||
case FButtonType of
|
||||
btPrev :
|
||||
begin
|
||||
FCanChangeDir := updDown;
|
||||
|
||||
if FCanChangePos - Increment >= Min then
|
||||
FCanChangePos := FCanChangePos - Increment
|
||||
else
|
||||
if Wrap then
|
||||
FCanChangePos := Max + (FCanChangePos - Increment - Min) + 1
|
||||
else
|
||||
FCanChangePos := Min;
|
||||
end;
|
||||
btNext :
|
||||
begin
|
||||
FCanChangeDir := updUp;
|
||||
|
||||
if FCanChangePos + Increment <= Max then
|
||||
FCanChangePos := FCanChangePos + Increment
|
||||
else
|
||||
If Wrap then
|
||||
FCanChangePos := Min + (FCanChangePos + Increment - Max) - 1
|
||||
else
|
||||
FCanChangePos := Max;
|
||||
end;
|
||||
|
||||
end;
|
||||
if not CanChange then Exit;
|
||||
Position := FCanChangePos;
|
||||
|
||||
Click(FButtonType);
|
||||
end;
|
||||
FUpDown.Click(FButtonType);
|
||||
end;
|
||||
|
||||
constructor TUpDownButton.CreateWithParams(UpDown : TCustomUpDown;
|
||||
@ -264,10 +237,10 @@ end;
|
||||
|
||||
procedure TCustomUpDown.BTimerExec(Sender : TObject);
|
||||
var
|
||||
AInterval:Integer;
|
||||
AInterval: Integer;
|
||||
begin
|
||||
If Assigned(FMouseTimerEvent)
|
||||
and PtInRect(FMouseDownBounds,Mouse.CursorPos) then begin
|
||||
If Assigned(FMouseTimerEvent) and PtInRect(FMouseDownBounds, Mouse.CursorPos) then
|
||||
begin
|
||||
AInterval := TTimer(Sender).Interval;
|
||||
if AInterval > FMinRepeatInterval then begin
|
||||
AInterval := AInterval - 25;
|
||||
@ -369,7 +342,36 @@ end;
|
||||
|
||||
procedure TCustomUpDown.Click(Button: TUDBtnType);
|
||||
begin
|
||||
if Assigned(FOnClick) then FOnClick(Self, Button);
|
||||
FCanChangePos := Position;
|
||||
FCanChangeDir := updNone;
|
||||
case Button of
|
||||
btPrev :
|
||||
begin
|
||||
FCanChangeDir := updDown;
|
||||
if FCanChangePos - Increment >= Min then
|
||||
FCanChangePos := FCanChangePos - Increment
|
||||
else
|
||||
if Wrap then
|
||||
FCanChangePos := Max + (FCanChangePos - Increment - Min) + 1
|
||||
else
|
||||
FCanChangePos := Min;
|
||||
end;
|
||||
btNext :
|
||||
begin
|
||||
FCanChangeDir := updUp;
|
||||
if FCanChangePos + Increment <= Max then
|
||||
FCanChangePos := FCanChangePos + Increment
|
||||
else
|
||||
If Wrap then
|
||||
FCanChangePos := Min + (FCanChangePos + Increment - Max) - 1
|
||||
else
|
||||
FCanChangePos := Max;
|
||||
end;
|
||||
end;
|
||||
if not CanChange then Exit;
|
||||
Position := FCanChangePos;
|
||||
if Assigned(FOnClick) then
|
||||
FOnClick(Self, Button);
|
||||
end;
|
||||
|
||||
procedure TCustomUpDown.SetAssociate(Value: TWinControl);
|
||||
@ -536,6 +538,18 @@ begin
|
||||
TCustomSpeedButton(FMaxBtn).Click;
|
||||
end;
|
||||
|
||||
procedure TCustomUpDown.MouseEnter;
|
||||
begin // This should never happen because buttons cover the whole component.
|
||||
Assert(False, 'TCustomUpDown.MouseEnter called!');
|
||||
CheckMouseEntering;
|
||||
end;
|
||||
|
||||
procedure TCustomUpDown.MouseLeave;
|
||||
begin // This should never happen because buttons cover the whole component.
|
||||
Assert(False, 'TCustomUpDown.MouseLeave called!');
|
||||
CheckMouseLeaving;
|
||||
end;
|
||||
|
||||
procedure TCustomUpDown.DoSetBounds(ALeft, ATop, AWidth, AHeight: integer);
|
||||
begin
|
||||
inherited;
|
||||
@ -575,14 +589,35 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomUpDown.Notification(AComponent: TComponent;
|
||||
Operation: TOperation);
|
||||
procedure TCustomUpDown.Notification(AComponent: TComponent; Operation: TOperation);
|
||||
begin
|
||||
inherited Notification(AComponent, Operation);
|
||||
if (Operation = opRemove) and (AComponent = FAssociate) then
|
||||
SetAssociate(nil);
|
||||
end;
|
||||
|
||||
procedure TCustomUpDown.CheckMouseEntering;
|
||||
// Mouse in entering this control.
|
||||
begin
|
||||
if FMouseInsideComp then Exit; // Already inside, moving between 2 buttons.
|
||||
inherited MouseEnter;
|
||||
FMouseInsideComp := True;
|
||||
end;
|
||||
|
||||
procedure TCustomUpDown.CheckMouseLeaving;
|
||||
// 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;
|
||||
end;
|
||||
|
||||
function TCustomUpDown.GetPosition: SmallInt;
|
||||
var
|
||||
av,I : Integer;
|
||||
@ -593,10 +628,7 @@ begin
|
||||
str := Trim(Associate.Caption);
|
||||
str := StringReplace(str, DefaultFormatSettings.ThousandSeparator, '', [rfReplaceAll]);
|
||||
if not TryStrToInt(str, AV) then
|
||||
begin
|
||||
Result := FPosition;
|
||||
Exit;
|
||||
end;
|
||||
Exit(FPosition);
|
||||
//this will also correct for AV > High(SmallInt) or AV < Low(SMallInt)
|
||||
If AV > FMax then
|
||||
AV := FMax;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user