paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-17 22:59:15 +02:00
Code Issues Packages Projects Releases Wiki Activity

lcl: toolbutton: when clicked on button part of tbsDropDown, do not paint arrow as down. It's native appearance on Win&Linux.

Browse Source 
Further info: This is different from Delphi. Delphi paints the arrow as down in this case, but other applications (MS Office, Adobe, Thunderbird) don't do it. Linux applications don't do it either.

git-svn-id: trunk@50957 -
This commit is contained in:
ondrej 2015-12-20 17:31:34 +00:00
parent 0d604bed83
commit fda56cd53f
2 changed files with 56 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
lcl/comctrls.pp
View File

@ -1956,7 +1956,8 @@ type
TToolButtonFlag =
(
tbfPressed, // set while mouse is pressed on button
tbfArrowPressed // set while mouse is pressed on arrow button
tbfArrowPressed,// set while mouse is pressed on arrow button
tbfMouseInArrow // set while mouse is on arrow button
);
TToolButtonFlags = set of TToolButtonFlag;
@ -1993,6 +1994,7 @@ type
FUpdateCount: Integer;
FWrap: Boolean;
FLastDropDownTick: QWord;
FLastDown: Boolean;
procedure GetGroupBounds(var StartIndex, EndIndex: integer);
function GetIndex: Integer;
function GetTextSize: TSize;
@ -2027,6 +2029,7 @@ type
procedure AssignTo(Dest: TPersistent); override;
procedure BeginUpdate; virtual;
procedure EndUpdate; virtual;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseEnter; override;
@ -2059,6 +2062,7 @@ type
Raw: boolean = false;
WithThemeSpace: boolean = true); override;
property Index: Integer read GetIndex;
function PointInArrow(const X, Y: Integer): Boolean;
published
property Action;
property AllowAllUp: Boolean read FAllowAllUp write FAllowAllUp default False;

57
lcl/include/toolbutton.inc
View File

@ -84,7 +84,7 @@ begin
// therefore the condition is always met.
if Enabled and not(GetTickCount64 < FLastDropDownTick + 100) then
begin
if (Style = tbsDropDown) and (FToolBar <> nil) and (X > ClientWidth - FToolBar.GetRealDropDownWidth) then
if PointInArrow(X, Y) then
Include(NewFlags, tbfArrowPressed)
else
Include(NewFlags, tbfPressed);
@ -96,6 +96,8 @@ begin
end;
end;
FLastDown := Down;
inherited MouseDown(Button, Shift, X, Y);
FLastDropDownTick := 0;
@ -127,13 +129,23 @@ procedure TToolButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
var
Pressed: Boolean;
Pt: TPoint;
NewFlags: TToolButtonFlags;
begin
//DebugLn(['TToolButton.MouseUp ',Name,':',ClassName,' ',dbgs(ord(Button)),' ',X,',',Y]);
Pressed := (Button = mbLeft) and ([tbfArrowPressed, tbfPressed] * FToolButtonFlags <> []);
FLastDown := False;
NewFlags := FToolButtonFlags;
Pressed := (Button = mbLeft) and ([tbfArrowPressed, tbfPressed] * NewFlags <> []);
if Pressed then
begin
Exclude(FToolButtonFlags, tbfPressed);
Exclude(FToolButtonFlags, tbfArrowPressed);
Exclude(NewFlags, tbfPressed);
Exclude(NewFlags, tbfArrowPressed);
end;
if (tbfMouseInArrow in NewFlags) and PointInArrow(X, Y) then
Exclude(NewFlags, tbfMouseInArrow);
if NewFlags <> FToolButtonFlags then
begin
FToolButtonFlags := NewFlags;
Invalidate;
end;
@ -191,7 +203,10 @@ procedure TToolButton.Paint;
begin
ArrowState := TThemedToolBar(ord(ttbSplitButtonDropDownNormal) + OwnerDetails.State - 1);
if (tbfArrowPressed in FToolButtonFlags) and FMouseInControl and Enabled then
ArrowState := ttbSplitButtonDropDownPressed;
ArrowState := ttbSplitButtonDropDownPressed
else
if (FToolButtonFlags*[tbfMouseInArrow,tbfPressed] = [tbfPressed]) and not FLastDown then
ArrowState := ttbSplitButtonDropDownHot;
end;
Details := ThemeServices.GetElementDetails(ArrowState);
if (FToolBar <> nil) and (not FToolBar.Flat)
@ -445,6 +460,13 @@ begin
inherited Paint;
end;
function TToolButton.PointInArrow(const X, Y: Integer): Boolean;
begin
Result := (Style = tbsDropDown) and (FToolBar <> nil)
and (Y >= 0) and (Y <= ClientHeight)
and (X > ClientWidth - FToolBar.GetRealDropDownWidth) and (X <= ClientWidth);
end;
procedure TToolButton.Loaded;
begin
inherited Loaded;
@ -535,14 +557,37 @@ procedure TToolButton.MouseLeave;
begin
// DebugLn('TToolButton.MouseLeave ',Name);
inherited MouseLeave;
if (not MouseCapture) and ([tbfPressed, tbfArrowPressed] * FToolButtonFlags <> []) then
if (not MouseCapture) and ([tbfPressed, tbfArrowPressed, tbfMouseInArrow] * FToolButtonFlags <> []) then
begin
Exclude(FToolButtonFlags, tbfPressed);
Exclude(FToolButtonFlags, tbfArrowPressed);
Exclude(FToolButtonFlags, tbfMouseInArrow);
end;
SetMouseInControl(false);
end;
procedure TToolButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
NewFlags: TToolButtonFlags;
begin
inherited MouseMove(Shift, X, Y);
if (not MouseCapture) and (Style = tbsDropDown) and (FToolBar <> nil) then
begin
NewFlags := FToolButtonFlags;
if PointInArrow(X, Y) then
Include(NewFlags, tbfMouseInArrow)
else
Exclude(NewFlags, tbfMouseInArrow);
if NewFlags <> FToolButtonFlags then
begin
FToolButtonFlags := NewFlags;
Invalidate;
end;
end;
end;
procedure TToolButton.SetDown(Value: Boolean);
var
StartIndex, EndIndex: integer;