paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-08 11:56:11 +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; FMarked: Boolean;
FMenuItem: TMenuItem; FMenuItem: TMenuItem;
FMouseInControl: boolean; FMouseInControl: boolean;
FOnArrowClick: TNotifyEvent;
FShowCaption: boolean; FShowCaption: boolean;
FStyle: TToolButtonStyle; FStyle: TToolButtonStyle;
FToolButtonFlags: TToolButtonFlags; FToolButtonFlags: TToolButtonFlags;
@ -2056,6 +2057,7 @@ type
constructor Create(TheOwner: TComponent); override; constructor Create(TheOwner: TComponent); override;
function CheckMenuDropdown: Boolean; virtual; function CheckMenuDropdown: Boolean; virtual;
procedure Click; override; procedure Click; override;
procedure ArrowClick; virtual;
procedure GetCurrentIcon(var ImageList: TCustomImageList; procedure GetCurrentIcon(var ImageList: TCustomImageList;
var TheIndex: integer); virtual; var TheIndex: integer); virtual;
procedure GetPreferredSize(var PreferredWidth, PreferredHeight: integer; procedure GetPreferredSize(var PreferredWidth, PreferredHeight: integer;
@ -2080,6 +2082,7 @@ type
property Indeterminate: Boolean read FIndeterminate write SetIndeterminate default False; property Indeterminate: Boolean read FIndeterminate write SetIndeterminate default False;
property Marked: Boolean read FMarked write SetMarked default False; property Marked: Boolean read FMarked write SetMarked default False;
property MenuItem: TMenuItem read FMenuItem write SetMenuItem; property MenuItem: TMenuItem read FMenuItem write SetMenuItem;
property OnArrowClick: TNotifyEvent read FOnArrowClick write FOnArrowClick;
property OnClick; property OnClick;
property OnContextPopup; property OnContextPopup;
property OnDragDrop; property OnDragDrop;

23
lcl/include/toolbutton.inc
View File

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