mirrors/doublecmd
2
0
Fork 0
mirror of https://github.com/doublecmd/doublecmd.git synced 2026-06-28 10:02:14 +00:00
Code Issues Projects Releases Packages Wiki Activity
doublecmd/components/KASToolBar/kastoolbar.pas
Denis Bisson 92565d38a5 ADD: Tree View Menu implementation. 
ADD: The possibility to use a concept of "Tree View Menu" where the possible actions offered to the user are placed into a tree view. There is above an edit box where user might enter a few letters to eliminate the non-matching choices from the visual field so only the matching ones are remaining visible. User might use arrows keys to move up and down through possible selectable items from the three. He might even use ALT+KEY shorcut to select item. This way, user might choose quicker when list are long without having to give much attention.
ADD: The "Tree View Menu" are not offered by default so it won't impact on user by default. User needs to activate the "Tree View Menu" presentation from "Tree View Menu" configuration page.
ADD: "Tree View Menu" may be activated for selection from hot directories configured independently if it was called from internal command "cm_DirHotList" or from a double click for the top of the panel.
ADD: "Tree View Menu" may be activated for selection from favorite tabs configured independently if it was called from internal command "cm_LoadFavoriteTabs" or from a double click on a tabs.
ADD: "Tree View Menu" may be activated for selection from directories in dir history.
ADD: "Tree View Menu" may be activated for selection from directories in fileview history, 
ADD: "Tree View Menu" may be activated for selection  of commands when looking at the command line history. 
UPD: The internal commands "cm_ShowMainMenu" may now supports the parameter "treeview" with boolean possible values to offer the possibility to choose item from main menu items through a "Tree View Menu" look.
UPD: Put back in action the internal command "cm_ShowButtonMenu" to make visible or not the toolbar with the parameter "toolbar" with boolean possible values.
UPD: The internal commands "cm_ShowButtonMenu" may now supports the parameter "treeview" with boolean possible values to offer the possibility to choose item from toolbar items through a "Tree View Menu" look.
ADD: In the TKASToolBar, add a "PublicExecuteToolItem" function so given a "TKASToolItem", we may call its execution directly from it.
ADD: Two new configuration pages related with the "Tree View Menus" which are a page for basic settings "fOptionsTreeViewMenu" and one for colors "fOptionsTreeViewMenuColor".
ADD: Add new 32x32 icon for the commands "cm_configtreeviewmenus" and "cm_configtreeviewmenuscolors".
UPD: Change 32x32 icon for the "cm_showbuttonmenu" so it looks like a little more to a DC toolbar.
UPD: New parameter "position=" for the internal command "cm_DirHotList" with possible values "panel" or "cursor" to determine where it will be shown. Previous one was not documented and use only internally so no need to respect legacy here.
2016-04-17 23:24:04 +00:00

1094 lines
32 KiB
ObjectPascal
Raw Blame History

{
Double Commander components
-------------------------------------------------------------------------
Toolbar panel class
Copyright (C) 2006-2016 Koblov Alexander (Alexx2000@mail.ru)
contributors:
2012 Przemyslaw Nagay (cobines@gmail.com)
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
in a file called COPYING along with this program; if not, write to
the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
02139, USA.
}
unit KASToolBar;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, ComCtrls,
Graphics, Dialogs, ExtCtrls, Buttons, FileUtil, Menus,
DCXmlConfig, KASToolItems, LCLVersion;
type
TOnToolButtonClick = procedure (Sender: TObject) of object;
TOnToolButtonMouseUpDown = procedure (Sender: TObject; Button: TMouseButton; Shift:TShiftState; X,Y:Integer) of object;
TOnToolButtonMouseMove = procedure (Sender: TObject; Shift:TShiftState; X,Y:Integer; NumberOfButton: Integer) of object;
TOnToolButtonDragOver = procedure(Sender, Source: TObject; X,Y: Integer;
State: TDragState; var Accept: Boolean; NumberOfButton: Integer) of object;
TOnToolButtonDragDrop = procedure(Sender, Source: TObject; X, Y: Integer) of object;
TOnToolButtonEndDrag = procedure(Sender, Target: TObject; X,Y: Integer) of object;
TOnLoadButtonGlyph = function (ToolItem: TKASToolItem; iIconSize: Integer; clBackColor: TColor): TBitmap of object;
TOnToolItemExecute = procedure (ToolItem: TKASToolItem) of object;
TOnConfigLoadItem = function (Config: TXmlConfig; Node: TXmlNode): TKASToolItem of object;
TOnToolItemShortcutsHint = function (ToolItem: TKASNormalItem): String of object;
TTypeOfConfigurationLoad = (tocl_FlushCurrentToolbarContent, tocl_AddToCurrentToolbarContent);
TKASToolBar = class;
{ TKASToolButton }
TKASToolButton = class(TSpeedButton)
private
FToolItem: TKASToolItem;
function GetToolBar: TKASToolBar;
protected
procedure CalculatePreferredSize(var PreferredWidth,
PreferredHeight: integer; WithThemeSpace: Boolean); override;
public
constructor Create(AOwner: TComponent; Item: TKASToolItem); reintroduce;
property ToolBar: TKASToolBar read GetToolBar;
property ToolItem: TKASToolItem read FToolItem;
end;
{ TKASToolDivider }
TKASToolDivider = class(TKASToolButton)
protected
procedure CalculatePreferredSize(var PreferredWidth,
PreferredHeight: integer; WithThemeSpace: Boolean); override;
procedure Paint; override;
end;
{ TKASToolBar }
TKASToolBar = class(TToolBar, IToolOwner)
private
FButtonHeight: Integer;
FButtonWidth: Integer;
FFlat: Boolean;
FGlyphSize: Integer;
FRadioToolBar: Boolean;
FRowHeight: Integer;
FShowDividerAsButton: Boolean;
FToolItemExecutors: TFPList;
FToolItems: TKASToolBarItems;
FToolPopupMenu: TPopupMenu;
FOwnsToolItems: Boolean;
{$if lcl_fullversion < 1010000}
FUpdateCount: Integer;
{$endif}
FOnToolButtonClick: TOnToolButtonClick;
FOnToolButtonMouseDown: TOnToolButtonMouseUpDown;
FOnToolButtonMouseUp: TOnToolButtonMouseUpDown;
FOnToolButtonMouseMove: TOnToolButtonMouseMove;
FOnToolButtonDragOver: TOnToolButtonDragOver;
FOnToolButtonDragDrop: TOnToolButtonDragDrop;
FOnToolButtonEndDrag: TOnToolButtonEndDrag;
FOnLoadButtonGlyph: TOnLoadButtonGlyph;
FOnToolItemExecute: TOnToolItemExecute;
FOnToolItemShortcutsHint: TOnToolItemShortcutsHint;
FKASToolBarFlags: TToolBarFlags;
FResizeButtonsNeeded: Boolean;
procedure AssignToolButtonProperties(ToolButton: TKASToolButton);
procedure ClearExecutors;
function CreateButton(Item: TKASToolItem): TKASToolButton;
function ExecuteToolItem(Item: TKASToolItem): Boolean;
function FindButton(Button: TKASToolButton): Integer;
function GetChangePath: String;
function GetEnvVar: String;
function GetToolItemShortcutsHint(Item: TKASToolItem): String;
function LoadBtnIcon(IconPath: String): TBitMap;
procedure DrawLinkIcon(Image: TBitMap);
function GetButton(Index: Integer): TKASToolButton;
procedure InsertButton(InsertAt: Integer; ToolButton: TKASToolButton);
procedure SetButtonHeight(const AValue: Integer);
procedure SetButtonWidth(const AValue: Integer);
procedure SetChangePath(const {%H-}AValue: String);
procedure SetEnvVar(const {%H-}AValue: String);
procedure SetFlat(const AValue: Boolean);
procedure SetGlyphSize(const AValue: Integer);
procedure ShowMenu(ToolButton: TKASToolButton);
procedure ToolButtonClick(Sender: TObject);
procedure ToolButtonMouseDown(Sender: TObject; Button: TMouseButton; Shift:TShiftState; X,Y:Integer);
procedure ToolButtonMouseUp(Sender: TObject; Button: TMouseButton; Shift:TShiftState; X,Y:Integer);
procedure ToolButtonMouseMove(Sender: TObject; Shift:TShiftState; X,Y:Integer);
procedure ToolButtonDragOver(Sender, Source: TObject; X,Y: Integer; State: TDragState; var Accept: Boolean);
procedure ToolButtonDragDrop(Sender, Source: TObject; X,Y: Integer);
procedure ToolButtonEndDrag(Sender, Target: TObject; X, Y: Integer);
procedure ToolItemLoaded(Item: TKASToolItem);
procedure ToolMenuClicked(Sender: TObject);
procedure UpdateButtonsTags;
protected
procedure CalculatePreferredSize(var PreferredWidth,
PreferredHeight: Integer; WithThemeSpace: Boolean); override;
procedure ControlsAligned; override;
procedure FontChanged(Sender: TObject); override;
function WrapButtons(UseWidth: integer;
out NewWidth, NewHeight: Integer; Simulate: boolean): Boolean;
procedure ResizeButtons;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
function AddButton(Item: TKASToolItem): TKASToolButton;
procedure AddToolItemExecutor(ToolItemClass: TKASToolItemClass;
ExecuteFunction: TOnToolItemExecute);
procedure Clear;
procedure ClickItem(ToolItemID: String); overload;
function InsertButton(InsertAt: Integer; Item: TKASToolItem): TKASToolButton;
function InsertButton(InsertAt: TKASToolButton; Item: TKASToolItem): TKASToolButton;
procedure MoveButton(ButtonIndex, MovePosition: Integer);
procedure MoveButton(SourceButton: TKASToolButton; TargetToolBar: TKASToolBar; InsertAt: TKASToolButton);
procedure RemoveButton(Index: Integer);
procedure RemoveButton(Button: TKASToolButton);
procedure RemoveToolItemExecutor(ExecuteFunction: TOnToolItemExecute);
procedure UncheckAllButtons;
procedure UpdateIcon(ToolButton: TKASToolButton);
procedure UseItems(AItems: TKASToolBarItems);
procedure LoadConfiguration(Config: TXmlConfig; RootNode: TXmlNode;
Loader: TKASToolBarLoader; ConfigurationLoadType:TTypeOfConfigurationLoad);
procedure SaveConfiguration(Config: TXmlConfig; RootNode: TXmlNode);
procedure BeginUpdate; override;
procedure EndUpdate; override;
procedure SetButtonSize(NewButtonWidth, NewButtonHeight: Integer);
function PublicExecuteToolItem(Item: TKASToolItem): Boolean;
property Buttons[Index: Integer]: TKASToolButton read GetButton;
property RowHeight: Integer read FRowHeight;
published
property OnLoadButtonGlyph : TOnLoadButtonGlyph read FOnLoadButtonGlyph write FOnLoadButtonGlyph;
property OnToolButtonClick: TOnToolButtonClick read FOnToolButtonClick write FOnToolButtonClick;
property OnToolButtonMouseDown: TOnToolButtonMouseUpDown read FOnToolButtonMouseDown write FOnToolButtonMouseDown;
property OnToolButtonMouseUp: TOnToolButtonMouseUpDown read FOnToolButtonMouseUp write FOnToolButtonMouseUp;
property OnToolButtonMouseMove: TOnToolButtonMouseMove read FOnToolButtonMouseMove write FOnToolButtonMouseMove;
property OnToolButtonDragDrop: TOnToolButtonDragDrop read FOnToolButtonDragDrop write FOnToolButtonDragDrop;
property OnToolButtonEndDrag: TOnToolButtonEndDrag read FOnToolButtonEndDrag write FOnToolButtonEndDrag;
property OnToolButtonDragOver: TOnToolButtonDragOver read FOnToolButtonDragOver write FOnToolButtonDragOver;
property OnToolItemExecute: TOnToolItemExecute read FOnToolItemExecute write FOnToolItemExecute;
property OnToolItemShortcutsHint: TOnToolItemShortcutsHint read FOnToolItemShortcutsHint write FOnToolItemShortcutsHint;
property RadioToolBar: Boolean read FRadioToolBar write FRadioToolBar default False;
property Flat: Boolean read FFlat write SetFlat default False;
property GlyphSize: Integer read FGlyphSize write SetGlyphSize;
property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 22;
property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 23;
property ShowDividerAsButton: Boolean read FShowDividerAsButton write FShowDividerAsButton default False;
property ChangePath: String read GetChangePath write SetChangePath;
property EnvVar: String read GetEnvVar write SetEnvVar;
end;
procedure Register;
implementation
uses
Themes, types, math, DCOSUtils;
type
PToolItemExecutor = ^TToolItemExecutor;
TToolItemExecutor = record
ToolItemClass: TKASToolItemClass;
ToolItemExecute: TOnToolItemExecute;
end;
procedure Register;
begin
RegisterComponents('KASComponents',[TKASToolBar]);
end;
{ TKASToolBar }
procedure TKASToolBar.InsertButton(InsertAt: Integer; ToolButton: TKASToolButton);
begin
if InsertAt < 0 then
InsertAt:= 0;
if InsertAt > ButtonList.Count then
InsertAt:= ButtonList.Count;
ButtonList.Insert(InsertAt, ToolButton);
FToolItems.Insert(InsertAt, ToolButton.ToolItem);
UpdateButtonsTags;
ResizeButtons;
end;
function TKASToolBar.InsertButton(InsertAt: TKASToolButton; Item: TKASToolItem): TKASToolButton;
var
Index: Integer;
begin
Index := ButtonList.IndexOf(InsertAt);
if Index < 0 then
Index := ButtonCount;
Result := InsertButton(Index, Item);
end;
procedure TKASToolBar.CalculatePreferredSize(var PreferredWidth,
PreferredHeight: Integer; WithThemeSpace: Boolean);
begin
WrapButtons(Width, PreferredWidth, PreferredHeight, True);
end;
procedure TKASToolBar.ControlsAligned;
var
NewWidth, NewHeight: integer;
begin
if tbfPlacingControls in FKASToolBarFlags then exit;
Include(FKASToolBarFlags, tbfPlacingControls);
try
WrapButtons(Width, NewWidth, NewHeight, False);
finally
Exclude(FKASToolBarFlags, tbfPlacingControls);
end;
end;
procedure TKASToolBar.FontChanged(Sender: TObject);
begin
inherited FontChanged(Sender);
ResizeButtons;
end;
function TKASToolBar.WrapButtons(UseWidth: integer;
out NewWidth, NewHeight: Integer; Simulate: boolean): Boolean;
var
ARect: TRect;
x: Integer;
y: Integer;
CurControl: TControl;
StartX: Integer;
procedure CalculatePosition;
var
NewBounds: TRect;
begin
NewBounds := Bounds(x, y, CurControl.Width, RowHeight);
repeat
if (not Wrapable) or
(NewBounds.Right <= ARect.Right) or
(NewBounds.Left = StartX) then
begin
// control fits into the row
x := NewBounds.Left;
y := NewBounds.Top;
break;
end;
// try next row
NewBounds.Left := StartX;
NewBounds.Right := NewBounds.Left + CurControl.Width;
inc(NewBounds.Top, RowHeight);
inc(NewBounds.Bottom, RowHeight);
until false;
end;
var
CurClientRect: TRect;
AdjustClientFrame: TRect;
i: Integer;
w, h: Longint;
begin
Result := True;
NewWidth := 0;
NewHeight := 0;
DisableAlign;
BeginUpdate;
try
CurClientRect := ClientRect;
inc(CurClientRect.Right, UseWidth - Width);
ARect := CurClientRect;
AdjustClientRect(ARect);
AdjustClientFrame.Left := ARect.Left - CurClientRect.Left;
AdjustClientFrame.Top := ARect.Top - CurClientRect.Top;
AdjustClientFrame.Right := CurClientRect.Right - ARect.Right;
AdjustClientFrame.Bottom := CurClientRect.Bottom - ARect.Bottom;
//DebugLn(['TToolBar.WrapButtons ',DbgSName(Self),' ARect=',dbgs(ARect)]);
// important: top, left button must start in the AdjustClientRect top, left
// otherwise Toolbar.AutoSize=true will create an endless loop
StartX := ARect.Left;
x := StartX;
y := ARect.Top;
for i := 0 to ButtonList.Count - 1 do
begin
CurControl := TControl(ButtonList[i]);
if not CurControl.IsControlVisible then
Continue;
CalculatePosition;
w := CurControl.Width;
h := CurControl.Height;
if (not Simulate) and ((CurControl.Left <> x) or (CurControl.Top <> y)) then
begin
CurControl.SetBounds(x,y,w,h); // Note: do not use SetBoundsKeepBase
end;
// adjust NewWidth, NewHeight
NewWidth := Max(NewWidth, x + w + AdjustClientFrame.Right);
NewHeight := Max(NewHeight, y + h + AdjustClientFrame.Bottom);
// step to next position
inc(x,w);
end;
finally
EndUpdate;
EnableAlign;
end;
end;
procedure TKASToolBar.ResizeButtons;
var
w, h: LongInt;
i: Integer;
CurControl: TControl;
begin
if FUpdateCount > 0 then
begin
FResizeButtonsNeeded := True;
Exit;
end;
InvalidatePreferredChildSizes;
FRowHeight := ButtonHeight; // Row height is at least initial button height
// First recalculate RowHeight.
for i := 0 to ButtonList.Count - 1 do
begin
CurControl := TControl(ButtonList[i]);
w := ButtonWidth;
h := ButtonHeight;
CurControl.GetPreferredSize(w, h);
if FRowHeight < h then
FRowHeight := h;
end;
FResizeButtonsNeeded := False;
// Now resize buttons.
DisableAlign;
BeginUpdate;
try
for i := 0 to ButtonList.Count - 1 do
begin
CurControl := TControl(ButtonList[i]);
w := ButtonWidth;
h := RowHeight;
CurControl.GetPreferredSize(w, h);
if (CurControl.Width <> w) or (CurControl.Height <> h) then
CurControl.SetBounds(CurControl.Left, CurControl.Top, w, h);
end;
InvalidatePreferredSize;
AdjustSize;
finally
EndUpdate;
EnableAlign;
end;
end;
procedure TKASToolBar.SaveConfiguration(Config: TXmlConfig; RootNode: TXmlNode);
var
Node: TXmlNode;
Item: TKASToolItem;
i: Integer;
begin
if ButtonCount > 0 then
begin
Node := Config.AddNode(RootNode, 'Row');
for i := 0 to ButtonCount - 1 do
begin
Item := TKASToolButton(Buttons[i]).ToolItem;
Item.Save(Config, Node);
end;
end;
end;
procedure TKASToolBar.DrawLinkIcon(Image: TBitMap);
var
sizeLink : Integer;
bmLinkIcon : TBitmap;
{$IFDEF LCLGTK2}
bmTempIcon : TBitmap;
{$ENDIF}
ToolItem: TKASNormalItem;
begin
if (Image = nil) or (FOnLoadButtonGlyph = nil) then Exit;
sizeLink := FGlyphSize div 2;
ToolItem := TKASNormalItem.Create;
ToolItem.Icon := 'emblem-symbolic-link';
bmLinkIcon:= FOnLoadButtonGlyph(ToolItem, sizeLink, clBtnFace);
ToolItem.Free;
if Assigned(bmLinkIcon) then
begin
{$IFDEF LCLGTK2} // Under GTK2 can not draw over alpha transparent pixels
bmTempIcon := TBitmap.Create;
bmTempIcon.Assign(Image);
Image.FreeImage;
Image.SetSize(FGlyphSize, FGlyphSize);
Image.Canvas.Brush.Color := clBtnFace;
Image.Canvas.FillRect(0, 0, FGlyphSize, FGlyphSize);
Image.Canvas.Draw(0, 0, bmTempIcon);
bmTempIcon.Free;
{$ENDIF}
Image.Canvas.Draw(FGlyphSize-sizeLink+2,FGlyphSize-sizeLink+2, bmLinkIcon);
Image.TransparentColor:= clBtnFace;
Image.Transparent:= True;
bmLinkIcon.Free;
end;
end;
function TKASToolBar.LoadBtnIcon(IconPath: String): TBitMap;
var
picture: TPicture;
begin
if (IconPath = '') or (not mbFileExists(IconPath)) then Exit(nil);
Picture := TPicture.Create;
try
Picture.LoadFromFile(IconPath);
Result := TBitmap.Create;
Result.Assign(Picture.Bitmap);
finally
FreeAndNil(Picture);
end;
end;
procedure TKASToolBar.LoadConfiguration(Config: TXmlConfig; RootNode: TXmlNode;
Loader: TKASToolBarLoader; ConfigurationLoadType:TTypeOfConfigurationLoad);
var
Node: TXmlNode;
begin
BeginUpdate;
if ConfigurationLoadType=tocl_FlushCurrentToolbarContent then
begin
Clear;
Application.ProcessMessages;
end;
try
Node := Config.FindNode(RootNode, 'Row', False);
if Assigned(Node) then
Loader.Load(Config, Node, @ToolItemLoaded);
finally
EndUpdate;
end;
end;
procedure TKASToolBar.AssignToolButtonProperties(ToolButton: TKASToolButton);
begin
ToolButton.OnClick:= @ToolButtonClick;
ToolButton.OnMouseDown:= @ToolButtonMouseDown;
ToolButton.OnMouseUp:= @ToolButtonMouseUp;
ToolButton.OnMouseMove:= @ToolButtonMouseMove;
ToolButton.OnDragDrop:= @ToolButtonDragDrop;
ToolButton.OnDragOver:= @ToolButtonDragOver;
ToolButton.OnEndDrag:= @ToolButtonEndDrag;
end;
function TKASToolBar.GetChangePath: String;
begin
end;
function TKASToolBar.GetEnvVar: String;
begin
end;
function TKASToolBar.GetToolItemShortcutsHint(Item: TKASToolItem): String;
begin
Result := '';
if Assigned(FOnToolItemShortcutsHint) and (Item is TKASNormalItem) then
Result := FOnToolItemShortcutsHint(TKASNormalItem(Item));
end;
function TKASToolBar.GetButton(Index: Integer): TKASToolButton;
begin
Result:= TKASToolButton(ButtonList.Items[Index]);
end;
procedure TKASToolBar.SetChangePath(const AValue: String);
begin
end;
procedure TKASToolBar.SetEnvVar(const AValue: String);
begin
end;
procedure TKASToolBar.SetFlat(const AValue: Boolean);
var
I: Integer;
begin
FFlat:= AValue;
for I:= 0 to ButtonList.Count - 1 do
TKASToolButton(ButtonList.Items[I]).Flat:= FFlat;
end;
procedure TKASToolBar.SetGlyphSize(const AValue: Integer);
var
I: Integer;
begin
if FGlyphSize = AValue then Exit;
FGlyphSize:= AValue;
BeginUpdate;
try
for I := 0 to ButtonList.Count - 1 do
UpdateIcon(TKASToolButton(ButtonList[i]));
finally
EndUpdate;
end;
end;
procedure TKASToolBar.ShowMenu(ToolButton: TKASToolButton);
procedure MakeMenu(PopupMenu: TMenuItem; MenuItem: TKASMenuItem);
var
I: Integer;
Item: TKASToolItem;
PopupMenuItem: TMenuItem;
BitmapTmp: TBitmap = nil;
sText: String;
begin
for I := 0 to MenuItem.SubItems.Count - 1 do
begin
Item := MenuItem.SubItems.Items[I];
if Item is TKASSeparatorItem then
begin
PopupMenu.AddSeparator;
end
else
begin
PopupMenuItem := TMenuItem.Create(PopupMenu);
sText := Item.GetEffectiveText;
if sText = '' then
sText := Item.GetEffectiveHint;
PopupMenuItem.Caption := StringReplace(StringReplace(sText, #$0A, ' | ', [rfReplaceAll]), ' | ----', '', [rfReplaceAll]);
if Item is TKASNormalItem then
begin
if Assigned(FOnLoadButtonGlyph) then
BitmapTmp := FOnLoadButtonGlyph(Item, 16, clMenu);
if not Assigned(BitmapTmp) then
BitmapTmp := LoadBtnIcon(TKASNormalItem(Item).Icon);
PopupMenuItem.Bitmap := BitmapTmp;
FreeAndNil(BitmapTmp);
end;
PopupMenuItem.Tag := PtrInt(Item);
PopupMenuItem.OnClick := TNotifyEvent(@ToolMenuClicked);
PopupMenu.Add(PopupMenuItem);
if Item is TKASMenuItem then
MakeMenu(PopupMenuItem, TKASMenuItem(Item));
end;
end;
end;
var
Point: TPoint;
begin
FToolPopupMenu.Free;
FToolPopupMenu := TPopupMenu.Create(Self);
MakeMenu(FToolPopupMenu.Items, ToolButton.ToolItem as TKASMenuItem);
Point.x := ToolButton.Left;
Point.y := ToolButton.Top + ToolButton.Height;
Point := Self.ClientToScreen(Point);
FToolPopupMenu.PopUp(Point.x, Point.y);
end;
procedure TKASToolBar.ToolButtonClick(Sender: TObject);
var
Button: TKASToolButton;
begin
Button := Sender as TKASToolButton;
// Do not allow depressing down buttons.
if FRadioToolBar and not Button.Down then
Button.Down := True;
if not ExecuteToolItem(Button.ToolItem) then
begin
if Assigned(FOnToolButtonClick) then
FOnToolButtonClick(Button)
else if Button.ToolItem is TKASMenuItem then
begin
ShowMenu(Button);
end;
end;
end;
procedure TKASToolBar.ToolButtonMouseDown(Sender: TObject; Button: TMouseButton; Shift:TShiftState; X,Y:Integer);
begin
if Assigned(FOnToolButtonMouseDown) then
FOnToolButtonMouseDown(Sender, Button, Shift, X,Y);
end;
procedure TKASToolBar.ToolButtonMouseUp(Sender: TObject; Button: TMouseButton; Shift:TShiftState; X,Y:Integer);
begin
if Assigned(FOnToolButtonMouseUp) then
FOnToolButtonMouseUp(Sender, Button, Shift, X,Y);
end;
procedure TKASToolBar.ToolItemLoaded(Item: TKASToolItem);
begin
AddButton(Item);
end;
procedure TKASToolBar.ToolMenuClicked(Sender: TObject);
begin
ExecuteToolItem(TKASToolItem((Sender as TMenuItem).Tag));
end;
procedure TKASToolBar.ToolButtonMouseMove(Sender: TObject; Shift:TShiftState; X,Y:Integer);
begin
if Assigned(FOnToolButtonMouseMove) then
FOnToolButtonMouseMove(Sender, Shift, X,Y, (Sender as TSpeedButton).Tag);
end;
procedure TKASToolBar.ToolButtonDragOver(Sender, Source: TObject; X,Y: Integer; State: TDragState; var Accept: Boolean);
begin
if Assigned(FOnToolButtonDragOver) then
FOnToolButtonDragOver(Sender, Source, X,Y, State, Accept, (Sender as TSpeedButton).Tag);
end;
procedure TKASToolBar.ToolButtonDragDrop(Sender, Source: TObject; X,Y: Integer);
begin
if Assigned(FOnToolButtonDragDrop) then
FOnToolButtonDragDrop(Sender, Source, X, Y);
end;
procedure TKASToolBar.ToolButtonEndDrag(Sender, Target: TObject; X, Y: Integer);
begin
if Assigned(FOnToolButtonEndDrag) then
FOnToolButtonEndDrag(Sender, Target, X, Y);
end;
procedure TKASToolBar.MoveButton(ButtonIndex, MovePosition: Integer);
begin
ButtonList.Move(ButtonIndex, MovePosition);
FToolItems.Move(ButtonIndex, MovePosition);
UpdateButtonsTags;
ResizeButtons;
end;
procedure TKASToolBar.MoveButton(SourceButton: TKASToolButton; TargetToolBar: TKASToolBar; InsertAt: TKASToolButton);
var
Index: Integer;
begin
Index := FindButton(SourceButton);
if (Index <> -1) and (FToolItems[Index] = SourceButton.ToolItem) then
begin
SourceButton.FToolItem := nil;
TargetToolBar.InsertButton(InsertAt, FToolItems.ReleaseItem(Index));
ButtonList.Delete(Index);
Application.ReleaseComponent(SourceButton); // Free later
UpdateButtonsTags;
Resize;
end;
end;
procedure TKASToolBar.UpdateButtonsTags;
var
I: Integer;
begin
for I:= 0 to ButtonList.Count - 1 do
TKASToolButton(ButtonList.Items[I]).Tag:= I;
end;
procedure TKASToolBar.UpdateIcon(ToolButton: TKASToolButton);
var
Bitmap: TBitmap = nil;
begin
try
if Assigned(FOnLoadButtonGlyph) then
Bitmap := FOnLoadButtonGlyph(ToolButton.ToolItem, FGlyphSize, clBtnFace);
if not Assigned(Bitmap) and (ToolButton.ToolItem is TKASNormalItem) then
Bitmap := LoadBtnIcon(TKASNormalItem(ToolButton.ToolItem).Icon);
try
if (ToolButton.ToolItem is TKASMenuItem) and Assigned(Bitmap) then
DrawLinkIcon(Bitmap);
ToolButton.Glyph.Assign(Bitmap);
finally
Bitmap.Free;
end;
except
// Ignore
end;
end;
procedure TKASToolBar.UseItems(AItems: TKASToolBarItems);
var
i: Integer;
Button: TKASToolButton;
begin
if Assigned(AItems) then
begin
BeginUpdate;
Clear;
if FOwnsToolItems then
FToolItems.Free;
FToolItems := AItems;
FOwnsToolItems := False;
// Insert the existing items as buttons.
for i := 0 to FToolItems.Count - 1 do
begin
Button := CreateButton(FToolItems.Items[i]);
if Assigned(Button) then
ButtonList.Insert(ButtonCount, Button);
end;
UpdateButtonsTags;
ResizeButtons;
EndUpdate;
end;
end;
procedure TKASToolBar.Clear;
var
I: Integer;
begin
BeginUpdate;
for I := 0 to ButtonList.Count - 1 do
TKASToolButton(ButtonList.Items[I]).Free;
ButtonList.Clear;
if Assigned(FToolItems) then
FToolItems.Clear;
EndUpdate;
end;
procedure TKASToolBar.ClearExecutors;
var
I: Integer;
begin
for I := 0 to FToolItemExecutors.Count - 1 do
Dispose(PToolItemExecutor(FToolItemExecutors[I]));
FToolItemExecutors.Clear;
end;
procedure TKASToolBar.ClickItem(ToolItemID: String);
var
I: Integer;
Button: TKASToolButton;
NormalItem: TKASNormalItem;
begin
for I := 0 to ButtonList.Count - 1 do
begin
Button := TKASToolButton(ButtonList.Items[I]);
if Button.ToolItem is TKASNormalItem then
begin
NormalItem := TKASNormalItem(Button.ToolItem);
if NormalItem.ID = ToolItemID then
begin
Button.Click;
Break;
end;
if Button.ToolItem.CheckExecute(ToolItemID) then
Break;
end;
end;
end;
procedure TKASToolBar.SetButtonHeight(const AValue: Integer);
begin
SetButtonSize(ButtonWidth, AValue);
end;
procedure TKASToolBar.SetButtonWidth(const AValue: Integer);
begin
SetButtonSize(AValue, ButtonHeight);
end;
constructor TKASToolBar.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
FGlyphSize:= 16; // by default
FUpdateCount:= 0;
FButtonWidth := 23;
FButtonHeight := 22;
FKASToolBarFlags := [];
FToolItemExecutors := TFPList.Create;
FToolItems := TKASToolBarItems.Create;
FOwnsToolItems := True;
end;
function TKASToolBar.CreateButton(Item: TKASToolItem): TKASToolButton;
begin
if Assigned(Item) then
begin
if FOwnsToolItems then
Item.SetToolOwner(Self);
if Item is TKASSeparatorItem then
begin
Result := TKASToolDivider.Create(Self, Item);
end
else
begin
Result := TKASToolButton.Create(Self, Item);
Result.ShowHint := True;
Result.Caption := Item.GetEffectiveText;
Result.Hint := Item.GetEffectiveHint;
end;
Result.Flat := FFlat;
if FRadioToolBar then
begin
Result.GroupIndex := 1;
Result.AllowAllUp := True;
end;
Result.ShowCaption := ShowCaptions;
UpdateIcon(Result);
AssignToolButtonProperties(Result);
Result.Parent := Self;
end
else
Result := nil;
end;
destructor TKASToolBar.Destroy;
begin
if not FOwnsToolItems then
FToolItems := nil; // Unassign before Clear so that items are not cleared.
Clear;
inherited Destroy;
ClearExecutors;
FToolItemExecutors.Free;
if FOwnsToolItems then
FToolItems.Free;
end;
function TKASToolBar.ExecuteToolItem(Item: TKASToolItem): Boolean;
var
I: Integer;
Executor: PToolItemExecutor;
BestMatch: PToolItemExecutor = nil;
begin
for I := 0 to FToolItemExecutors.Count - 1 do
begin
Executor := PToolItemExecutor(FToolItemExecutors[I]);
if Assigned(Executor^.ToolItemExecute) and
Item.InheritsFrom(Executor^.ToolItemClass) and
(not Assigned(BestMatch) or
(Executor^.ToolItemClass.InheritsFrom(BestMatch^.ToolItemClass))) then
begin
BestMatch := Executor;
end;
end;
Result := Assigned(BestMatch);
if Result then
BestMatch^.ToolItemExecute(Item);
end;
{ TKASToolBar.PublicExecuteToolItem }
function TKASToolBar.PublicExecuteToolItem(Item: TKASToolItem): Boolean;
begin
result:=ExecuteToolItem(Item);
end;
procedure TKASToolBar.BeginUpdate;
begin
{$if lcl_fullversion < 1010000}
Inc(FUpdateCount);
{$endif}
inherited BeginUpdate;
DisableAutoSizing;
end;
procedure TKASToolBar.EndUpdate;
begin
EnableAutoSizing;
inherited EndUpdate;
{$if lcl_fullversion < 1010000}
Dec(FUpdateCount);
{$endif}
if (FUpdateCount = 0) and FResizeButtonsNeeded then
ResizeButtons;
end;
function TKASToolBar.FindButton(Button: TKASToolButton): Integer;
var
I: Integer;
begin
for I := 0 to ButtonList.Count - 1 do
if TKASToolButton(ButtonList[I]) = Button then
Exit(I);
Result := -1;
end;
procedure TKASToolBar.SetButtonSize(NewButtonWidth, NewButtonHeight: Integer);
begin
FButtonWidth := NewButtonWidth;
FButtonHeight := NewButtonHeight;
ResizeButtons;
end;
function TKASToolBar.AddButton(Item: TKASToolItem): TKASToolButton;
begin
Result := InsertButton(ButtonCount, Item);
end;
procedure TKASToolBar.AddToolItemExecutor(ToolItemClass: TKASToolItemClass; ExecuteFunction: TOnToolItemExecute);
var
Executor: PToolItemExecutor;
begin
New(Executor);
FToolItemExecutors.Add(Executor);
Executor^.ToolItemClass := ToolItemClass;
Executor^.ToolItemExecute := ExecuteFunction;
end;
function TKASToolBar.InsertButton(InsertAt: Integer; Item: TKASToolItem): TKASToolButton;
begin
Result := CreateButton(Item);
if Assigned(Result) then
InsertButton(InsertAt, Result);
end;
procedure TKASToolBar.RemoveButton(Index: Integer);
var
Button: TKASToolButton;
begin
Button := TKASToolButton(ButtonList.Items[Index]);
ButtonList.Delete(Index);
Button.Free;
FToolItems.Remove(Index);
UpdateButtonsTags;
Resize;
end;
procedure TKASToolBar.RemoveButton(Button: TKASToolButton);
var
Index: Integer;
begin
Index := FindButton(Button);
if Index <> -1 then
RemoveButton(Index);
end;
procedure TKASToolBar.RemoveToolItemExecutor(ExecuteFunction: TOnToolItemExecute);
var
Executor: PToolItemExecutor;
I: Integer;
begin
for I := FToolItemExecutors.Count - 1 downto 0 do
begin
Executor := PToolItemExecutor(FToolItemExecutors[I]);
if (TMethod(Executor^.ToolItemExecute).Code = TMethod(ExecuteFunction).Code) and
(TMethod(Executor^.ToolItemExecute).Data = TMethod(ExecuteFunction).Data) then
begin
Dispose(Executor);
FToolItemExecutors.Delete(I);
end;
end;
end;
procedure TKASToolBar.UncheckAllButtons;
var
I: Integer;
begin
for I:= 0 to ButtonCount - 1 do
Buttons[I].Down:= False;
end;
{ TKASToolButton }
procedure TKASToolButton.CalculatePreferredSize(var PreferredWidth,
PreferredHeight: integer; WithThemeSpace: Boolean);
var
TextSize: TSize;
begin
if Assigned(Parent) then
begin
if ShowCaption and (Caption <> EmptyStr) then
begin
// Size to extent of the icon + caption.
// Minimum size is the ButtonWidth x RowHeight of the toolbar.
TextSize := Canvas.TextExtent(Caption);
PreferredWidth := Max(TextSize.cx + Glyph.Width + 16, ToolBar.ButtonWidth);
PreferredHeight := Max(TextSize.cy + 4, ToolBar.RowHeight);
end
else
begin
PreferredWidth := ToolBar.ButtonWidth;
PreferredHeight := ToolBar.RowHeight;
end;
end
else
inherited;
end;
constructor TKASToolButton.Create(AOwner: TComponent; Item: TKASToolItem);
begin
inherited Create(AOwner);
FToolItem := Item;
end;
function TKASToolButton.GetToolBar: TKASToolBar;
begin
Result := Parent as TKASToolBar;
end;
{ TKASToolDivider }
procedure TKASToolDivider.CalculatePreferredSize(var PreferredWidth,
PreferredHeight: integer; WithThemeSpace: Boolean);
begin
if Assigned(Parent) and (Parent is TKASToolBar) and
not TKASToolBar(Parent).FShowDividerAsButton then
begin
PreferredWidth := 5;
PreferredHeight := TKASToolBar(Parent).RowHeight;
end
else
inherited;
end;
procedure TKASToolDivider.Paint;
var
DividerRect: TRect;
Details: TThemedElementDetails;
begin
if Assigned(Parent) and (Parent is TKASToolBar) and
not TKASToolBar(Parent).FShowDividerAsButton then
begin
DividerRect:= ClientRect;
Details:= ThemeServices.GetElementDetails(ttbSeparatorNormal);
// Theme services have no strict rule to draw divider in the center,
// so we should calculate rectangle here
// on windows 7 divider can't be less than 4 pixels
if (DividerRect.Right - DividerRect.Left) > 5 then
begin
DividerRect.Left := (DividerRect.Left + DividerRect.Right) div 2 - 3;
DividerRect.Right := DividerRect.Left + 5;
end;
ThemeServices.DrawElement(Canvas.GetUpdatedHandle([csBrushValid, csPenValid]), Details, DividerRect);
end
else
inherited Paint;
end;
end.
Reference in a new issue View git blame Copy permalink