paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-05 07:08:23 +02:00
Code Issues Packages Projects Releases Wiki Activity
main
lazarus/lcl/include/toolbar.inc

1363 lines
40 KiB
PHP
Raw Permalink Blame History

{%MainUnit ../comctrls.pp}
{******************************************************************************
TToolbar
******************************************************************************
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
}
type
TToolBarSpeedButton = class(TSpeedButton)
private
FMenuItemIndex: integer;
end;
{ TToolBarMenuItem }
TToolBarMenuItem = class(TMenuItem)
private
FOrigItem: TMenuItem;
protected
procedure DoClicked(var msg); message LM_ACTIVATE;
end;
{ TToolBarMenuItem }
procedure TToolBarMenuItem.DoClicked(var msg);
begin
if FOrigItem <> nil then
FOrigItem.Dispatch(msg);
end;
function CompareToolBarControlHorz(Control1, Control2: TControl): integer;
var
ToolBar: TToolBar;
Row1: Integer;
Row2: Integer;
HalfBtnHeight, BtnHeight: Integer;
begin
Result := 0;
if not (Control1.Parent is TToolBar) then Exit;
if Control1 is TToolBarSpeedButton then begin
if Control2 is TToolBarSpeedButton then
exit(TToolBarSpeedButton(Control1).FMenuItemIndex - TToolBarSpeedButton(Control2).FMenuItemIndex)
else
exit(-1);
end
else
if Control2 is TToolBarSpeedButton then
exit(1);
ToolBar := TToolBar(Control1.Parent);
BtnHeight := ToolBar.ButtonHeight;
if BtnHeight <= 0 then BtnHeight := 1;
HalfBtnHeight := BtnHeight div 2;
Row1 := (Control1.Top + HalfBtnHeight) div BtnHeight;
Row2 := (Control2.Top + HalfBtnHeight) div BtnHeight;
Result := CompareValue(Row1, Row2);
if Result = 0 then
begin
Result := CompareValue(Control1.Left, Control2.Left);
if ToolBar.UseRightToLeftAlignment then
Result:=-Result;
end;
if Result = 0 then
begin
Row1 := ToolBar.GetControlIndex(Control1);
Row2 := ToolBar.GetControlIndex(Control2);
Result := CompareValue(Row1, Row2);
end;
end;
function CompareToolBarControlVert(Control1, Control2: TControl): integer;
var
ToolBar: TToolBar;
Col1: Integer;
Col2: Integer;
HalfBtnWidth, BtnWidth: Integer;
begin
Result := 0;
if not (Control1.Parent is TToolBar) then Exit;
if Control1 is TToolBarSpeedButton then begin
if Control2 is TToolBarSpeedButton then
exit(TToolBarSpeedButton(Control1).FMenuItemIndex - TToolBarSpeedButton(Control2).FMenuItemIndex)
else
exit(-1);
end
else
if Control2 is TToolBarSpeedButton then
exit(1);
ToolBar := TToolBar(Control1.Parent);
BtnWidth := ToolBar.ButtonWidth;
if BtnWidth <= 0 then BtnWidth := 1;
HalfBtnWidth := BtnWidth div 2;
Col1 := (Control1.Left + HalfBtnWidth) div BtnWidth;
Col2 := (Control2.Left + HalfBtnWidth) div BtnWidth;
Result := CompareValue(Col1, Col2);
if Result = 0 then
Result := CompareValue(Control1.Top, Control2.Top);
if Result = 0 then
begin
Col1 := ToolBar.GetControlIndex(Control1);
Col2 := ToolBar.GetControlIndex(Control2);
Result := CompareValue(Col1, Col2);
end;
end;
{------------------------------------------------------------------------------
Method: TToolbar.Create
Params: AOwner: the owner of the class
Returns: Nothing
Constructor for the class.
------------------------------------------------------------------------------}
constructor TToolBar.Create(TheOwner: TComponent);
var
Details: TThemedElementDetails;
begin
inherited Create(TheOwner);
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csDoubleClicks, csMenuEvents, csSetCaption, csParentBackground, csOpaque];
FFlat := True;
Height := 32;
// ToDo: Test the scaling code. Widths are scaled in many places.
Details := ThemeServices.GetElementDetails(ttbSplitButtonDropDownNormal);
FThemeDropDownWidth := ThemeServices.GetDetailSize(Details).cx;
Details := ThemeServices.GetElementDetails(ttbDropDownButtonNormal);
FThemeButtonDropWidth := ThemeServices.GetDetailSize(Details).cx;
FButtonHeight := -1;
FButtonWidth := -1;
FDropDownWidth := -1;
FNewStyle := True;
FWrapable := True;
FButtons := TList.Create;
FMenuButtons := TList.Create;
FSubMenuItems := TList.Create;
FSubMenu := TPopupMenu.Create(Self);
FMenuObserver := TTMPObserver.Create;
FMenuObserver.DoOnChange := @UpdateMenuItem;
FMenuObserver.DoOnFree := @RemoveMenu;
FIndent := 1;
FList := False;
FImageChangeLink := TChangeLink.Create;
FImageChangeLink.OnChange := @ImageListChange;
FDisabledImageChangeLink := TChangeLink.Create;
FDisabledImageChangeLink.OnChange := @DisabledImageListChange;
FHotImageChangeLink := TChangeLink.Create;
FHotImageChangeLink.OnChange := @HotImageListChange;
EdgeBorders := [ebTop];
with GetControlClassDefaultSize do
SetInitialBounds(0, 0, CX, CY);
Align := alTop;
end;
destructor TToolBar.Destroy;
var
I: Integer;
begin
for I := 0 to FButtons.Count - 1 do
if TControl(FButtons[I]) is TToolButton then
TToolButton(FButtons[I]).FToolBar := nil;
for I := 0 to FMenuButtons.Count - 1 do
if TControl(FMenuButtons[I]) is TToolBarSpeedButton then
TToolBarSpeedButton(FMenuButtons[I]).Free;
if Assigned(FMenu) then FMenu.FPODetachObserver(FMenuObserver);
FreeThenNil(FButtons);
FreeThenNil(FMenuButtons);
FreeAndNil(FSubMenu);
FreeThenNil(FSubMenuItems);
FreeAndNil(FMenuObserver);
FreeThenNil(FHotImageChangeLink);
FreeThenNil(FImageChangeLink);
FreeThenNil(FDisabledImageChangeLink);
inherited Destroy;
end;
procedure TToolBar.FlipChildren(AllLevels: Boolean);
begin
if AllLevels then ;
// no flipping
end;
procedure TToolBar.CreateWnd;
begin
BeginUpdate;
try
DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TToolBar.CreateWnd'){$ENDIF};
try
inherited CreateWnd;
UpdateVisibleBar;
finally
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TToolBar.CreateWnd'){$ENDIF};
end;
finally
EndUpdate;
end;
end;
procedure TToolBar.AlignControls(AControl: TControl;
var RemainingClientRect: TRect);
var
NewWidth, NewHeight: integer;
begin
if tbfPlacingControls in FToolBarFlags then exit;
Include(FToolBarFlags, tbfPlacingControls);
DisableAlign;
try
AdjustClientRect(RemainingClientRect);
if IsVertical then
WrapButtons(Height, NewWidth, NewHeight, False)
else
WrapButtons(Width, NewWidth, NewHeight, False);
finally
Exclude(FToolBarFlags, tbfPlacingControls);
EnableAlign;
end;
end;
procedure TToolBar.RepositionButton(Index: Integer);
begin
if ([csLoading,csDestroying]*ComponentState<>[]) then exit;
UpdateVisibleBar;
end;
procedure TToolBar.RepositionButtons(Index: Integer);
begin
UpdateVisibleBar;
end;
procedure TToolBar.SetButtonHeight(const AValue: Integer);
begin
SetButtonSize(ButtonWidth,AValue);
end;
procedure TToolBar.SetButtonWidth(const AValue: Integer);
begin
SetButtonSize(AValue,ButtonHeight);
end;
procedure TToolBar.ImageListChange(Sender: TObject);
begin
if (Sender = Images) then UpdateVisibleBar;
end;
procedure TToolBar.SetShowCaptions(const AValue: Boolean);
begin
if FShowCaptions = AValue then exit;
FShowCaptions := AValue;
UpdateVisibleBar;
end;
procedure TToolBar.CloseCurrentMenu;
begin
FCurrentMenu.Close;
// move menu items back
if Assigned(FSrcMenuItem) then
begin
MoveSubMenuItems(FCurrentMenu.Items, FSrcMenuItem);
if Assigned(FDropDownButton) then
FDropDownButton.Down := False;
end;
end;
procedure TToolBar.MoveSubMenuItems(SrcMenuItem, DestMenuItem: TMenuItem);
var
i: Integer;
MovingMenuItem: TMenuItem;
begin
if (SrcMenuItem = nil) or (DestMenuItem = nil) or (SrcMenuItem = DestMenuItem) then
Exit;
for i := SrcMenuItem.Count - 1 downto 0 do
begin
MovingMenuItem := SrcMenuItem.Items[i];
SrcMenuItem.Delete(i);
DestMenuItem.Insert(0, MovingMenuItem);
end;
end;
procedure TToolBar.AddButton(Button: TToolButton);
begin
FButtons.Add(Button);
end;
procedure TToolBar.RemoveButton(Button: TToolButton);
begin
if FDropDownButton=Button then FDropDownButton:=nil;
FButtons.Remove(Button);
end;
procedure TToolBar.UpdateMenuItem(Sender: TObject);
var
i, xpos, wglyph: Integer;
tmpMenuButton: TToolBarSpeedButton;
begin
xpos := 0;
while (FMenuButtons.Count > 0) do
begin
i := FMenuButtons.Count - 1;
tmpMenuButton := TToolBarSpeedButton(FMenuButtons.Items[i]);
FMenuButtons.Delete(i);
FreeAndNil(tmpMenuButton);
end;
if not Assigned(FMenu) then Exit;
for i := 0 to FMenu.Items.Count-1 do
if FMenu.Items[i].Visible then
begin
tmpMenuButton := TToolBarSpeedButton.Create(Self);
tmpMenuButton.AutoSize := False;
tmpMenuButton.Align := alNone;
tmpMenuButton.Alignment := taCenter;
tmpMenuButton.Height := FMenu.Height;
tmpMenuButton.Left := xpos;
tmpMenuButton.Flat := True;
tmpMenuButton.ParentFont := True;
tmpMenuButton.Color := Self.Color;
tmpMenuButton.ShowCaption := True;
tmpMenuButton.Caption := FMenu.Items[i].Caption;
tmpMenuButton.Enabled := FMenu.Items[i].Enabled;
tmpMenuButton.Visible := FMenu.Items[i].Visible;
tmpMenuButton.Margin := -1;
tmpMenuButton.Spacing := 7;
tmpMenuButton.FMenuItemIndex:= i;
wglyph := 0;
tmpMenuButton.Images := nil;
if Assigned(FMenu.Images) and (FMenu.Items[i].ImageIndex >= 0) then begin
if FMenu.Items[i].ImageIndex < FMenu.Images.Count then
begin
FMenu.Images.GetBitmap(FMenu.Items[i].ImageIndex, tmpMenuButton.Glyph);
wglyph := tmpMenuButton.Glyph.Width + 5;
end;
end
else
if Assigned(FMenu.Items[i].Bitmap) then begin
tmpMenuButton.Glyph := FMenu.Items[i].Bitmap;
wglyph := tmpMenuButton.Glyph.Width + 5;
end;
tmpMenuButton.OnClick := @MenuButtonClick;
tmpMenuButton.Parent := Self;
if FMenu.Items[i].Default then tmpMenuButton.Font.Style := [fsBold];
tmpMenuButton.Width := Self.Canvas.TextWidth(FMenu.Items[i].Caption) + wglyph + 14;
tmpMenuButton.Constraints.MinWidth := tmpMenuButton.Width;
tmpMenuButton.Constraints.MaxWidth := tmpMenuButton.Width;
tmpMenuButton.Update;
Inc(xpos, tmpMenuButton.Width);
FMenuButtons.Add(tmpMenuButton);
end;
end;
procedure TToolBar.RemoveMenu(Sender: TObject);
begin
FMenu.FPODetachObserver(FMenuObserver);
FMenu := nil;
end;
procedure TToolBar.MenuButtonClick(Sender: TObject);
var
MenuButton: TToolBarSpeedButton;
SubMenuPos: TPoint;
tmpMI: TMenuItem;
function NewItem(const ACaption: string; AShortCut: TShortCut; AChecked,
TheEnabled: Boolean; hCtx: THelpContext;
const AName: string): TMenuItem;
begin
Result:=TToolBarMenuItem.Create(nil);
with Result do begin
Caption:=ACaption;
ShortCut:=AShortCut;
HelpContext:=hCtx;
Checked:=AChecked;
Enabled:=TheEnabled;
Name:=AName;
end;
end;
procedure PrepSubMenuItem(SubMenuItemIn, SubMenuItemOut: TMenuItem);
var
i: Integer;
begin
for i := 0 to SubMenuItemIn.Count - 1 do
begin
SubMenuItemOut.Add(NewItem(SubMenuItemIn.Items[i].Caption,
SubMenuItemIn.Items[i].ShortCut,
SubMenuItemIn.Items[i].Checked,
SubMenuItemIn.Items[i].Visible,
SubMenuItemIn.Items[i].HelpContext,
''));
SubMenuItemOut.Items[i].AutoCheck := SubMenuItemIn.Items[i].AutoCheck;
SubMenuItemOut.Items[i].AutoLineReduction := SubMenuItemIn.Items[i].AutoLineReduction;
SubMenuItemOut.Items[i].Default := SubMenuItemIn.Items[i].Default;
SubMenuItemOut.Items[i].GlyphShowMode := SubMenuItemIn.Items[i].GlyphShowMode;
SubMenuItemOut.Items[i].GroupIndex := SubMenuItemIn.Items[i].GroupIndex;
SubMenuItemOut.Items[i].Hint := SubMenuItemIn.Items[i].Hint;
SubMenuItemOut.Items[i].Bitmap := SubMenuItemIn.Items[i].Bitmap;
SubMenuItemOut.Items[i].ImageIndex := SubMenuItemIn.Items[i].ImageIndex;
SubMenuItemOut.Items[i].RadioItem := SubMenuItemIn.Items[i].RadioItem;
SubMenuItemOut.Items[i].RightJustify := SubMenuItemIn.Items[i].RightJustify;
SubMenuItemOut.Items[i].ShortCutKey2 := SubMenuItemIn.Items[i].ShortCutKey2;
SubMenuItemOut.Items[i].ShowAlwaysCheckable := SubMenuItemIn.Items[i].ShowAlwaysCheckable;
SubMenuItemOut.Items[i].SubMenuImages := SubMenuItemIn.Items[i].SubMenuImages;
SubMenuItemOut.Items[i].SubMenuImagesWidth := SubMenuItemIn.Items[i].SubMenuImagesWidth;
TToolBarMenuItem(SubMenuItemOut.Items[i]).FOrigItem := SubMenuItemIn.Items[i];
if SubMenuItemIn.Items[i].Count > 0 then PrepSubMenuItem(SubMenuItemIn.Items[i], SubMenuItemOut.Items[i]);
end;
end;
begin
MenuButton := TToolBarSpeedButton(Sender);
tmpMI := FMenu.Items[MenuButton.FMenuItemIndex];
if not Assigned(tmpMI) then Exit;
tmpMI.Click;
FSubMenu.Items.Clear;
if tmpMI.Count = 0 then Exit;
FSubMenu.Images := tmpMI.GetImageList;
PrepSubMenuItem(tmpMI, FSubMenu.Items);
SubMenuPos := ClientToScreen(TPoint.Create(MenuButton.Left, MenuButton.Top + MenuButton.Height));
FSubMenu.PopUp(SubMenuPos.X, SubMenuPos.Y);
end;
function TToolBar.IsVertical: Boolean;
begin
case FOrientation of
tboHorizontal: exit(False);
tboVertical: exit(True);
end;
if (Parent is TCoolBar) then
Exit(TCoolBar(Parent).Vertical);
if Align in [alNone, alClient, alCustom] then
Result := Height > Width
else
Result := Align in [alLeft, alRight];
end;
class procedure TToolBar.WSRegisterClass;
begin
inherited WSRegisterClass;
RegisterToolBar;
end;
procedure TToolBar.ApplyFontForButtons;
var
i: integer;
begin
for i := 0 to ButtonCount - 1 do
Buttons[i].Font := Font;
end;
function TToolBar.ButtonHeightIsStored: Boolean;
begin
Result := FButtonHeight >= 0;
end;
function TToolBar.ButtonWidthIsStored: Boolean;
begin
Result := FButtonWidth >= 0;
end;
function TToolBar.GetButton(Index: Integer): TToolButton;
begin
Result := TToolButton(FButtons[Index]);
end;
function TToolBar.GetButtonCount: Integer;
begin
Result := FButtons.Count;
end;
function TToolBar.GetTransparent: Boolean;
begin
Result := not (csOpaque in ControlStyle);
end;
procedure TToolBar.SetList(const AValue: Boolean);
begin
if FList = AValue then exit;
FList := AValue;
UpdateVisibleBar;
end;
procedure TToolBar.SetMenu(AValue: TMainMenu);
begin
if FMenu = AValue then Exit;
if Assigned(FMenu) then
begin
FMenu.FPODetachObserver(FMenuObserver);
end;
FMenu := AValue;
if Assigned(FMenu) then FMenu.FPOAttachObserver(FMenuObserver);
UpdateVisibleBar;
end;
procedure TToolBar.SetOrientation(AValue: TToolBarOrientation);
begin
if FOrientation = AValue then Exit;
FOrientation := AValue;
invalidate;
end;
procedure TToolBar.SetFlat(const AValue: Boolean);
begin
if FFlat = AValue then exit;
FFlat := AValue;
Invalidate;
end;
procedure TToolBar.SetTransparent(const AValue: Boolean);
begin
if GetTransparent = AValue then exit;
if AValue then
ControlStyle := ControlStyle - [csOpaque]
else
ControlStyle := ControlStyle + [csOpaque];
Invalidate;
end;
procedure TToolBar.SetWrapable(const AValue: Boolean);
begin
if FWrapable = AValue then exit;
FWrapable := AValue;
ReAlign;
end;
procedure TToolBar.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
begin
if AComponent = FMenu then Menu := nil;
if AComponent = FImages then Images := nil;
if AComponent = FHotImages then HotImages := nil;
if AComponent = FDisabledImages then DisabledImages := nil;
end;
end;
procedure TToolBar.SetImages(const AValue: TCustomImageList);
begin
if FImages = AValue then Exit;
if FImages <> nil then
FImages.UnRegisterChanges(FImageChangeLink);
FImages := AValue;
if FImages <> nil then
begin
FImages.RegisterChanges(FImageChangeLink);
FImages.FreeNotification(Self);
end;
UpdateVisibleBar;
end;
procedure TToolBar.SetImagesWidth(const aImagesWidth: Integer);
begin
if FImagesWidth = aImagesWidth then Exit;
FImagesWidth := aImagesWidth;
UpdateVisibleBar;
end;
procedure TToolBar.DisabledImageListChange(Sender: TObject);
begin
if (Sender = DisabledImages) then UpdateVisibleBar;
end;
procedure TToolBar.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double);
begin
inherited;
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
begin
BeginUpdate;
try
if ButtonWidthIsStored then
ButtonWidth := Round(ButtonWidth * AXProportion);
if ButtonHeightIsStored then
ButtonHeight := Round(ButtonHeight * AYProportion);
if DropDownWidthIsStored then
DropDownWidth := Round(DropDownWidth * AXProportion);
FRealizedButtonHeight := 0;
FRealizedButtonWidth := 0;
FRealizedDropDownWidth := 0;
FRealizedButtonDropWidth := 0;
FToolBarFlags := FToolBarFlags + [tbfUpdateVisibleBarNeeded];
finally
EndUpdate;
end;
end;
end;
procedure TToolBar.SetDisabledImages(const AValue: TCustomImageList);
begin
if FDisabledImages = AValue then Exit;
if FDisabledImages <> nil then
FDisabledImages.UnRegisterChanges(FDisabledImageChangeLink);
FDisabledImages := AValue;
if FDisabledImages <> nil then
begin
FDisabledImages.RegisterChanges(FDisabledImageChangeLink);
FDisabledImages.FreeNotification(Self);
end;
UpdateVisibleBar;
end;
procedure TToolBar.SetDropDownWidth(const ADropDownWidth: Integer);
begin
if FDropDownWidth = ADropDownWidth then Exit;
FDropDownWidth := ADropDownWidth;
UpdateVisibleBar;
end;
procedure TToolBar.HotImageListChange(Sender: TObject);
begin
if (Sender = HotImages) then UpdateVisibleBar;
end;
procedure TToolBar.UpdateVisibleBar;
var
i: Integer;
begin
if ([csLoading,csDestroying]*ComponentState<>[]) or (not HandleAllocated) then
begin
Include(FToolBarFlags,tbfUpdateVisibleBarNeeded);
Exit;
end;
UpdateMenuItem(Self);
for i := 0 to FButtons.Count - 1 do
begin
TControl(FButtons[i]).InvalidatePreferredSize;
TControl(FButtons[i]).AdjustSize;
end;
AdjustSize;
Invalidate;
Exclude(FToolBarFlags,tbfUpdateVisibleBarNeeded);
end;
procedure TToolBar.SetHotImages(const AValue: TCustomImageList);
begin
if FHotImages = AValue then Exit;
if FHotImages <> nil then
FHotImages.UnRegisterChanges(FHotImageChangeLink);
FHotImages := AValue;
if FHotImages <> nil then
begin
FHotImages.RegisterChanges(FHotImageChangeLink);
FHotImages.FreeNotification(Self);
end;
UpdateVisibleBar;
end;
procedure TToolBar.SetIndent(const AValue: Integer);
begin
if FIndent = AValue then exit;
FIndent := AValue;
UpdateVisibleBar;
end;
procedure TToolBar.Loaded;
begin
inherited Loaded;
UpdateVisibleBar;
end;
procedure TToolBar.EndUpdate;
var
i: Integer;
tmpMenuItem: TMenuItem;
begin
inherited EndUpdate;
if FUpdateCount=0 then begin
if tbfUpdateVisibleBarNeeded in FToolBarFlags then
UpdateVisibleBar;
end;
end;
function TToolBar.GetEnumerator: TToolBarEnumerator;
begin
Result := TToolBarEnumerator.Create(Self);
end;
function TToolBar.GetDropDownWidth: Integer;
begin
if FDropDownWidth < 0 then
begin
if FRealizedDropDownWidth = 0 then
FRealizedDropDownWidth := ScaleScreenToFont(FThemeDropDownWidth);
Result := FRealizedDropDownWidth;
end else
Result := FDropDownWidth;
end;
function TToolBar.GetButtonDropWidth: Integer;
begin
if FDropDownWidth < 0 then
begin
if FRealizedButtonDropWidth = 0 then
FRealizedButtonDropWidth := ScaleScreenToFont(FThemeButtonDropWidth);
Result := FRealizedButtonDropWidth;
end else
Result := FDropDownWidth+FThemeButtonDropWidth-FThemeDropDownWidth;
end;
function TToolBar.GetButtonHeight: Integer;
begin
if FButtonHeight < 0 then
begin
if FRealizedButtonHeight = 0 then
FRealizedButtonHeight := Scale96ToFont(cDefButtonHeight);
Result := FRealizedButtonHeight;
end else
Result := FButtonHeight;
end;
function TToolBar.GetButtonWidth: Integer;
begin
if FButtonWidth < 0 then
begin
if FRealizedButtonWidth = 0 then
FRealizedButtonWidth := Scale96ToFont(cDefButtonWidth);
Result := FRealizedButtonWidth;
end else
Result := FButtonWidth;
end;
procedure TToolBar.Paint;
begin
if csDesigning in ComponentState then
begin
Canvas.Pen.Color:=clRed;
Canvas.FrameRect(Clientrect);
end;
inherited Paint;
if Assigned(OnPaint) then
OnPaint(Self);
end;
procedure TToolBar.SetButtonSize(NewButtonWidth, NewButtonHeight: integer);
var
CurControl: TControl;
NewWidth: Integer;
NewHeight: Integer;
i, RealButtonWidth, RealButtonHeight: Integer;
ChangeW, ChangeH: Boolean;
begin
ChangeW := FButtonWidth <> NewButtonWidth;
ChangeH := FButtonHeight <> NewButtonHeight;
if not (ChangeW or ChangeH) then Exit;
FButtonWidth:=NewButtonWidth;
FButtonHeight:=NewButtonHeight;
RealButtonWidth := ButtonWidth;
RealButtonHeight := ButtonHeight;
if FUpdateCount > 0 then Exit;
if [csLoading, csDestroying] * ComponentState <> [] then Exit;
// set all children to ButtonWidth ButtonHeight
BeginUpdate;
try
for i:=ControlCount-1 downto 0 do
begin
CurControl := Controls[i];
CurControl.InvalidatePreferredSize;
NewWidth := CurControl.Width;
NewHeight := CurControl.Height;
// width
if ChangeW
and (RealButtonWidth > 0)
and not CurControl.AutoSize
and (CurControl is TToolButton)
and (CurControl.Align in [alNone, alLeft, alRight])
then begin
if TToolButton(CurControl).Style in [tbsButton,tbsCheck,tbsDropDown]
then begin
CurControl.GetPreferredSize(NewWidth,NewHeight);
if NewWidth < RealButtonWidth then
NewWidth := RealButtonWidth;
end;
end;
// height
// in horizontal toolbars the height is set by the toolbar independent of autosize
if ChangeH
and (RealButtonHeight > 0)
and ((Align in [alTop, alBottom]) or not CurControl.AutoSize)
then NewHeight := RealButtonHeight;
CurControl.SetBounds(CurControl.Left, CurControl.Top, NewWidth, NewHeight);
end;
finally
EndUpdate;
end;
end;
function TToolBar.CanFocus: Boolean;
begin
Result := False;
end;
procedure TToolBar.DoAutoSize;
begin
// children are moved in ControlsAligned independent of AutoSize=true
end;
function TToolBar.DropDownWidthIsStored: Boolean;
begin
Result := FDropDownWidth >= 0;
end;
procedure TToolBar.CalculatePreferredSize(var PreferredWidth,
PreferredHeight: integer; WithThemeSpace: Boolean);
var
AWidth: Integer;
NewWidth, NewHeight: Integer;
begin
NewWidth:=0;
NewHeight:=0;
if (Parent<>nil)
and (not Parent.AutoSize)
and AnchorSideLeft.IsAnchoredToParent(akLeft)
and AnchorSideRight.IsAnchoredToParent(akRight) then begin
// the width depends on the parent
// the width is fixed
AWidth:=Constraints.MinMaxWidth(Width);
end
else begin
AWidth:=Constraints.MinMaxWidth(Screen.Width);
end;
WrapButtons(AWidth,NewWidth,NewHeight,true);
PreferredWidth := NewWidth;
PreferredHeight := NewHeight;
//DebugLn(['TToolBar.CalculatePreferredSize ',DbgSName(Self),' ',PreferredWidth,'x',PreferredHeight,' Count=',ControlCount]);
end;
{------------------------------------------------------------------------------
function TToolBar.WrapButtons(var NewWidth, NewHeight: Integer): Boolean;
Position all controls, that have Align=alNone.
The controls are put from left to right.
If the controls don't fit in a row and Wrapable=true, then the next row is
started.
If Wrapable=false, then the row is wrapped after the first button with
Wrap=true.
------------------------------------------------------------------------------}
function TToolBar.WrapButtons(UseSize: integer;
out NewWidth, NewHeight: Integer; Simulate: boolean): Boolean;
var
ARect: TRect;
x, y, w, h: Integer;
NewControlWidth, NewControlHeight: Integer;
CurControl: TControl;
ObstacleControls: TFPList;
FullSizeObstacleControls: TFPList;
StartX, StartY: Integer;
Vertical: Boolean; // true = ToolBar is vertical, controls are put in rows
RowsLeftToRight: Boolean; // rows are left to right
RealButtonWidth, RealButtonHeight: Integer;
procedure CalculatePosition;
var
AlignedControl: TControl;
NewBounds: TRect;
SiblingBounds: TRect;
j: Integer;
PreferredBtnWidth, PreferredBtnHeight: Integer;
Intersects: Boolean;
IntersectsWithLimitedHeightControl: Boolean;
StartedAtRowStart: Boolean;
begin
// compute the size
if (CurControl is TToolButton) and (not CurControl.AutoSize) then
begin
PreferredBtnWidth := 0;
PreferredBtnHeight := 0;
CurControl.GetPreferredSize(PreferredBtnWidth, PreferredBtnHeight);
if Vertical then
begin
// column layout
NewControlHeight := PreferredBtnHeight;
NewControlWidth := RealButtonWidth;
end
else
begin
// row layout
NewControlHeight := RealButtonHeight;
NewControlWidth := PreferredBtnWidth;
end;
if (TToolButton(CurControl).Style in [tbsButton, tbsDropDown, tbsCheck]) then
begin
if Vertical then
begin
// column layout
if (NewControlHeight < RealButtonHeight) then
NewControlHeight := RealButtonHeight;
end
else begin
// row layout
if (NewControlWidth < RealButtonWidth) then
NewControlWidth := RealButtonWidth;
end;
end;
//debugln(['CalculatePosition preferred toolbutton size ',DbgSName(CurControl),' ',NewControlWidth,' ',NewControlHeight]);
end
else
if Vertical then
begin
// column layout
NewControlWidth := RealButtonWidth;
NewControlHeight := CurControl.Height;
end
else
begin
// row layout
NewControlWidth := CurControl.Width;
NewControlHeight := RealButtonHeight;
end;
if Vertical or RowsLeftToRight then
NewBounds := Bounds(x, y, NewControlWidth, NewControlHeight)
else
NewBounds := Bounds(x-NewControlWidth, y, NewControlWidth, NewControlHeight);
//DebugLn(['CalculatePosition ',DbgSName(CurControl),' NewBounds=',dbgs(NewBounds),' x=',x,' y=',y]);
if Vertical then
StartedAtRowStart := y = StartY
else
StartedAtRowStart := x = StartX;
repeat
// move control until it does not overlap
IntersectsWithLimitedHeightControl := False;
j := 0;
while j < ObstacleControls.Count do
begin
AlignedControl := TControl(ObstacleControls[j]);
SiblingBounds := AlignedControl.BoundsRect;
Intersects:=(SiblingBounds.Right > NewBounds.Left) and
(SiblingBounds.Left < NewBounds.Right) and
(SiblingBounds.Bottom > NewBounds.Top) and
(SiblingBounds.Top < NewBounds.Bottom);
if Intersects then
begin
//DebugLn(['CalculatePosition Move ',NewBounds.Left,'->',SiblingBounds.Right]);
if Vertical then
begin
// column layout
NewBounds.Top := SiblingBounds.Bottom;
NewBounds.Bottom := NewBounds.Top + NewControlHeight;
end
else
begin
// row layout
if RowsLeftToRight then
begin
NewBounds.Left := SiblingBounds.Right;
NewBounds.Right := NewBounds.Left + NewControlWidth;
end else begin
NewBounds.Right := SiblingBounds.Left;
NewBounds.Left := NewBounds.Right - NewControlWidth;
end;
end;
j := 0; // check again, needed, because ObstacleControls are not sorted
// (and can not be sorted, because they can overlap)
if FullSizeObstacleControls.IndexOf(AlignedControl) < 0 then
IntersectsWithLimitedHeightControl := True;
end
else
inc(j);
end;
if Vertical then
begin
// column layout
if (not Wrapable) or
(NewBounds.Bottom <= ARect.Bottom) or (NewBounds.Top = StartY) or
(StartedAtRowStart and not IntersectsWithLimitedHeightControl) then
begin
// control fits into the row
//DebugLn(['CalculatePosition fits: ',DbgSName(CurControl),' ',dbgs(NewBounds)]);
x := NewBounds.Left;
y := NewBounds.Top;
break;
end;
// try next row
NewBounds.Top := StartY;
NewBounds.Bottom := NewBounds.Top + NewControlHeight;
inc(NewBounds.Left, RealButtonWidth);
inc(NewBounds.Right, RealButtonWidth);
end
else
begin
// row layout
if (not Wrapable)
or (StartedAtRowStart and not IntersectsWithLimitedHeightControl)
or (RowsLeftToRight and ((NewBounds.Left = StartX) or (NewBounds.Right <= ARect.Right)))
or ((not RowsLeftToRight) and ((NewBounds.Right = StartX) or (NewBounds.Left >= ARect.Left)))
then begin
// control fits into the row
//DebugLn(['CalculatePosition fits: ',DbgSName(CurControl),' ',dbgs(NewBounds)]);
x := NewBounds.Left;
y := NewBounds.Top;
break;
end;
//debugln(['CalculatePosition overlaps: ',DbgSName(CurControl),' ',dbgs(NewBounds),' ARect=',DbgS(ARect),' StartX=',StartX]);
// try next row
inc(NewBounds.Top, RealButtonHeight);
inc(NewBounds.Bottom, RealButtonHeight);
if RowsLeftToRight then
begin
NewBounds.Left := StartX;
NewBounds.Right := NewBounds.Left + NewControlWidth;
end else begin
NewBounds.Right := StartX;
NewBounds.Left := NewBounds.Right - NewControlWidth;
end;
end;
StartedAtRowStart := True;
//DebugLn('CalculatePosition Next Row ',DbgSName(CurControl),' ',dbgs(NewBounds));
until false;
end;
function AnchoredToParent(AControl: TControl; Side: TAnchorKind): boolean;
var
AnchorControl: TControl;
AnchorSide: TAnchorSideReference;
p: integer;
begin
if not (Side in CurControl.Anchors) then exit(false);
AnchorControl:=nil;
CurControl.AnchorSide[Side].GetSidePosition(AnchorControl,AnchorSide,P);
if AnchorControl=nil then
AnchorControl:=CurControl;
Result:=(Side in AnchorControl.Anchors);
end;
var
OrderedControls: TFPList;
CurClientRect: TRect;
AdjustClientFrame: TRect;
i: Integer;
GrowSide: TAnchorKind; // when a line is full, grow the TToolBar in this direction
SeparatorWidthChange: Boolean;
begin
//DebugLn(['WrapButtons ',DbgSName(Self),' Wrapable=',Wrapable,' ',dbgs(BoundsRect),' Vertical=',IsVertical,' RTL=',UseRightToLeftAlignment,' Simulate=',Simulate]);
Result := True;
RealButtonWidth := ButtonWidth;
RealButtonHeight := ButtonHeight;
Vertical := IsVertical;
NewWidth := 0;
NewHeight := 0;
ObstacleControls := TFPList.Create;
FullSizeObstacleControls := TFPList.Create;
OrderedControls := TFPList.Create;
if not Simulate then
FRowCount := 0;
DisableAlign;
BeginUpdate;
try
if Vertical then
begin
GrowSide := akRight;
RowsLeftToRight := true;
end
else begin
GrowSide := akBottom;
RowsLeftToRight:=not UseRightToLeftAlignment;
end;
for i:=0 to ControlCount-1 do
begin
CurControl := Controls[i];
if CurControl.Align = alNone then begin
// this control will be auto positioned and auto sized by this function
// => set to Left,Top anchoring
CurControl.Anchors:=[akLeft,akTop];
CurControl.AnchorSide[akLeft].Control:=nil;
CurControl.AnchorSide[akTop].Control:=nil;
OrderedControls.Add(CurControl);
end else begin
// this control will be positioned/sized by the default LCL functions
// the OrderedControls will be positioned around them (without overlapping)
ObstacleControls.Add(CurControl);
// check if this obstacle auto grows, for example if this toolbar is
// aligned to the top, check if the obstacle grows downwards (Align=alLeft)
if AnchoredToParent(CurControl,GrowSide) then begin
// this obstacle auto grows (important for the wrap algorithm)
FullSizeObstacleControls.Add(CurControl);
end;
end;
end;
// sort OrderedControls
if Vertical then
OrderedControls.Sort(TListSortCompare(@CompareToolBarControlVert))
else
OrderedControls.Sort(TListSortCompare(@CompareToolBarControlHorz));
// position OrderedControls
CurClientRect := ClientRect;
if Vertical then
inc(CurClientRect.Bottom, UseSize - Height)
else
inc(CurClientRect.Right, UseSize - 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 corner of AdjustClientRect
// otherwise Toolbar.AutoSize=true will create an endless loop
if Vertical or RowsLeftToRight then
StartX := ARect.Left
else
StartX := ARect.Right;
StartY := ARect.Top;
x := StartX;
y := StartY;
//debugln(['TToolBar.WrapButtons Start=',StartX,' ',StartY]);
for i := 0 to OrderedControls.Count - 1 do
begin
CurControl := TControl(OrderedControls[i]);
if not CurControl.IsControlVisible then
Continue;
CalculatePosition;
//DebugLn(['WrapButtons ',DbgSName(CurControl),' ',x,',',y,',',CurControl.Width,'x',CurControl.Height]);
if CurControl.AutoSize then
begin
w := CurControl.Width;
h := CurControl.Height;
end
else
begin
w := NewControlWidth;
h := NewControlHeight;
end;
w := CurControl.Constraints.MinMaxWidth(w);
h := CurControl.Constraints.MinMaxHeight(h);
SeparatorWidthChange := (CurControl is TToolButton) and
(TToolButton(CurControl).Style in [tbsSeparator, tbsDivider]);
if SeparatorWidthChange then begin
if not Vertical then begin
SeparatorWidthChange := (w <> CurControl.Width);
w := CurControl.Width;
end else begin
SeparatorWidthChange := (h <> CurControl.Height);
h := CurControl.Height;
end;
end;
if Vertical <> FPrevVertical then //swap h/w when orientation changed
begin
if (CurControl is TToolButton) and
(TToolButton(CurControl).Style in [tbsSeparator, tbsDivider]) then
begin
if not Vertical then
w := CurControl.Height
else
h := CurControl.Width;
end;
end;
if (CurControl.Left <> x) or (CurControl.Top <> y) or
(CurControl.Width <> w) or (CurControl.Height <> h) then
begin
//DebugLn(['TToolBar.WrapButtons moving child: ',DbgSName(CurControl),' Old=',dbgs(CurControl.BoundsRect),' New=',dbgs(Bounds(x,y,w,h))]);
if not Simulate then
begin
//DebugLn(['TToolBar.WrapButtons moving child: ',DbgSName(CurControl),' Old=',dbgs(CurControl.BoundsRect),' New=',dbgs(Bounds(x,y,w,h))]);
if SeparatorWidthChange then
CurControl.SetBoundsKeepBase(x,y,w,h)
else
CurControl.SetBounds(x,y,w,h);
//DebugLn(['TToolBar.WrapButtons moved child: ',DbgSName(CurControl),' ',dbgs(CurControl.BoundsRect)]);
end;
end;
// adjust NewWidth, NewHeight
if Vertical or RowsLeftToRight then
NewWidth := Max(NewWidth, x + w + AdjustClientFrame.Right)
else
NewWidth := Max(NewWidth, ARect.Right - x + ARect.Left + AdjustClientFrame.Right);
NewHeight := Max(NewHeight, y + h + AdjustClientFrame.Bottom);
// step to next position
if Vertical then
begin
inc(y, h);
if not Wrapable and
(CurControl is TToolButton) and
(TToolButton(CurControl).Wrap) then
begin
// user forced wrap -> start new line
y := StartY;
inc(x, RealButtonWidth);
if not Simulate then
inc(FRowCount);
end;
end
else
begin
if RowsLeftToRight then
inc(x, w);
if not Wrapable and
(CurControl is TToolButton) and
(TToolButton(CurControl).Wrap) then
begin
// user forced wrap -> start new line
x := StartX;
inc(y, RealButtonHeight);
if not Simulate then
inc(FRowCount);
end;
end;
end;
finally
ObstacleControls.Free;
OrderedControls.Free;
FullSizeObstacleControls.Free;
EndUpdate;
EnableAlign;
FPrevVertical := Vertical;
end;
end;
procedure TToolBar.CNDropDownClosed(var Message: TLMessage);
begin
CloseCurrentMenu;
end;
procedure TToolBar.AdjustClientRect(var ARect: TRect);
begin
inherited AdjustClientRect(ARect);
inc(ARect.Left, Indent);
end;
class function TToolBar.GetControlClassDefaultSize: TSize;
begin
Result.CX := 150;
Result.CY := 26;
end;
function TToolBar.FindButtonFromAccel(Accel: Word): TToolButton;
var
i: Integer;
begin
for i := 0 to FButtons.Count - 1 do
if TControl(FButtons[i]) is TToolButton then
begin
Result := Buttons[i];
if Result.Visible and Result.Enabled and IsAccel(Accel, Result.Caption) then
Exit;
end;
Result := nil;
end;
procedure TToolBar.FontChanged(Sender: TObject);
begin
inherited FontChanged(Sender);
ApplyFontForButtons;
FRealizedButtonWidth := 0;
FRealizedButtonHeight := 0;
FRealizedDropDownWidth := 0;
FRealizedButtonDropWidth := 0;
end;
function TToolBar.CheckMenuDropdown(Button: TToolButton): Boolean;
var
APoint: TPoint;
begin
Result := False;
if Button = nil then
Exit;
if Assigned(FCurrentMenu) then
begin
CloseCurrentMenu;
if FCurrentMenuAutoFree then
begin
FreeAndNil(FCurrentMenu);
FCurrentMenuAutoFree := False;
end;
end;
FSrcMenuItem := nil;
FSrcMenu := nil;
FDropDownButton := Button;
if Assigned(Button.DropdownMenu) then
// the button has a popupenu
FCurrentMenu := Button.DropdownMenu
else
if Assigned(Button.MenuItem) then
begin
// the button has a menuitem
// since the button is clicked - menu item must be clicked too
Button.MenuItem.Click;
// -> create a temporary TPopupMenu and move all child menuitems
FCurrentMenuAutoFree := True;
FCurrentMenu := TPopupMenu.Create(Self);
FSrcMenuItem := Button.MenuItem;
FSrcMenu := FSrcMenuItem.GetParentMenu;
FCurrentMenu.Items.HelpContext := FSrcMenuItem.HelpContext;
if Assigned(FSrcMenu) then
FCurrentMenu.Images := FSrcMenu.Images;
MoveSubMenuItems(FSrcMenuItem, FCurrentMenu.Items);
end
else
Exit;
FCurrentMenu.PopupComponent := Self;
APoint := Button.ClientToScreen(Point(0, Button.ClientHeight));
if FCurrentMenu.IsRightToLeft then Inc(APoint.X, Button.Width);
FCurrentMenu.Popup(APoint.X, APoint.Y);
// The next command will be executed after popup menu close because Popup is a
// syncronous method. We can't send this message on Menu.Close event because
// Click happen after the Close event and if we remove all the menu items there
// we will not be able to handle the Click event
// we also need to postpone this message to allow after Popup cleanup and click happen
PostMessage(Handle, CN_DROPDOWNCLOSED, 0, 0);
Result := True;
end;
procedure TToolBar.ClickButton(Button: TToolButton);
begin
Button.Click;
end;
{ TToolBar.TTMPObserver }
procedure TToolBar.TTMPObserver.FPOObservedChanged(ASender: TObject;
Operation: TFPObservedOperation; Data: Pointer);
begin
case Operation of
ooFree: if Assigned(DoOnFree) then DoOnFree(ASender);
ooChange: if Assigned(DoOnChange) then DoOnChange(ASender);
end;
end;
procedure TToolBar.TTMPObserver.SetDoOnChange(AValue: TNotifyEvent);
begin
if FDoOnChange = AValue then Exit;
FDoOnChange := AValue;
end;
procedure TToolBar.TTMPObserver.SetDoOnFree(AValue: TNotifyEvent);
begin
if FDoOnFree = AValue then Exit;
FDoOnFree := AValue;
end;
Reference in New Issue View Git Blame Copy Permalink