{ Double Commander components ------------------------------------------------------------------------- Toolbar panel class Copyright (C) 2006-2010 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; 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 AValue: String); procedure SetEnvVar(const 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); procedure SaveConfiguration(Config: TXmlConfig; RootNode: TXmlNode); procedure BeginUpdate; override; procedure EndUpdate; override; procedure SetButtonSize(NewButtonWidth, NewButtonHeight: Integer); 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); var Node: TXmlNode; begin Clear; BeginUpdate; 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); var Depth: Integer = 0; 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 := sText; 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; ToolItem: TKASToolItem; 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; 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.