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

lcl: toolbutton: added ArrowClick method and OnArrowClick event that is called when user clicks on the arrow part in tbsDropDown.

Browse Source 
! Breaking change: Click/OnClick was called before.

git-svn-id: trunk@50959 -
This commit is contained in:
ondrej 2015-12-20 18:05:21 +00:00
parent b270c37757
commit ab5405d117
2 changed files with 23 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
lcl/comctrls.pp
View File

@ -1988,6 +1988,7 @@ type
FMarked: Boolean;
FMenuItem: TMenuItem;
FMouseInControl: boolean;
FOnArrowClick: TNotifyEvent;
FShowCaption: boolean;
FStyle: TToolButtonStyle;
FToolButtonFlags: TToolButtonFlags;
@ -2056,6 +2057,7 @@ type
constructor Create(TheOwner: TComponent); override;
function CheckMenuDropdown: Boolean; virtual;
procedure Click; override;
procedure ArrowClick; virtual;
procedure GetCurrentIcon(var ImageList: TCustomImageList;
var TheIndex: integer); virtual;
procedure GetPreferredSize(var PreferredWidth, PreferredHeight: integer;
@ -2080,6 +2082,7 @@ type
property Indeterminate: Boolean read FIndeterminate write SetIndeterminate default False;
property Marked: Boolean read FMarked write SetMarked default False;
property MenuItem: TMenuItem read FMenuItem write SetMenuItem;
property OnArrowClick: TNotifyEvent read FOnArrowClick write FOnArrowClick;
property OnClick;
property OnContextPopup;
property OnDragDrop;

29
lcl/include/toolbutton.inc
View File

@ -127,19 +127,19 @@ end;
procedure TToolButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
Pressed: Boolean;
ButtonPressed, ArrowPressed: Boolean;
Pt: TPoint;
NewFlags: TToolButtonFlags;
begin
//DebugLn(['TToolButton.MouseUp ',Name,':',ClassName,' ',dbgs(ord(Button)),' ',X,',',Y]);
FLastDown := False;
NewFlags := FToolButtonFlags;
Pressed := (Button = mbLeft) and ([tbfArrowPressed, tbfPressed] * NewFlags <> []);
if Pressed then
begin
ButtonPressed := (Button = mbLeft) and (tbfPressed in NewFlags);
ArrowPressed := (Button = mbLeft) and (tbfArrowPressed in NewFlags);
if ButtonPressed then
Exclude(NewFlags, tbfPressed);
if ArrowPressed then
Exclude(NewFlags, tbfArrowPressed);
end;
if (tbfMouseInArrow in NewFlags) and PointInArrow(X, Y) then
Exclude(NewFlags, tbfMouseInArrow);
@ -162,11 +162,16 @@ begin
if (Style in [tbsButton, tbsDropDown, tbsButtonDrop]) then
Down := False;
//button is pressed, but DropdownMenu was not shown
if FMouseInControl and (FLastDropDownTick = 0) and Pressed then
if FMouseInControl and (FLastDropDownTick = 0) then
begin
if (Style = tbsCheck) then
Down := not Down;
Click;
if ButtonPressed then
begin
if (Style = tbsCheck) then
Down := not Down;
Click;
end else
if ArrowPressed then
ArrowClick;
//DON'T USE the tool button (Self) after the click call because it could
//have been destroyed in the OnClick event handler (e.g. Lazarus IDE does it)!
end;
@ -513,6 +518,12 @@ begin
end;
end;
procedure TToolButton.ArrowClick;
begin
if Assigned(FOnArrowClick) then
FOnArrowClick(Self);
end;
function TToolButton.GetActionLinkClass: TControlActionLinkClass;
begin
Result := TToolButtonActionLink;