paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-05 15:58:15 +02:00
Code Issues Packages Projects Releases Wiki Activity
d55f9aba80
lazarus/lcl/include/toolbar.inc
lazarus d78e403562 MG: changed license to LGPL 
git-svn-id: trunk@997 -
2002-02-09 01:47:36 +00:00

1560 lines
40 KiB
PHP
Raw Blame History

{******************************************************************************
TToolbar
******************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.LCL, included in this distribution, *
* for details about the copyright. *
* *
* 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. *
* *
*****************************************************************************
}
{------------------------------------------------------------------------------
Method: TToolbar.Create
Params: AOwner: the owner of the class
Returns: Nothing
Constructor for the class.
------------------------------------------------------------------------------}
constructor TToolbar.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csDoubleClicks, csMenuEvents, csSetCaption];
Left := 1;
Top := 1;
Width := 150;
Height := 29;
Align := alTop;
EdgeBorders := [ebTop];
FButtonWidth := 23;
FButtonHeight := 22;
FNewStyle := True;
FWrapable := True;
FButtons := TList.Create;
fCompStyle := csToolbar;
FNullBitmap := TBitmap.Create;
with FNullBitmap do
begin
Width := 1;
Height := 1;
Canvas.Brush.Color := clBtnFace;
Canvas.FillRect(Rect(0,0,1,1));
end;
end;
destructor TToolBar.Destroy;
var
I: Integer;
begin
FNullBitmap.Free;
for I := 0 to FButtons.Count - 1 do
if TControl(FButtons[I]) is TToolButton then
TToolButton(FButtons[I]).FToolBar := nil;
FButtons.Free;
inherited Destroy;
end;
procedure TToolBar.CreateParams(var Params: TCreateParams);
const
TBSTYLE_TRANSPARENT = $8000; // IE4 style -this is not valid but still needed as a holder
DefaultStyles =
CCS_NOPARENTALIGN or CCS_NOMOVEY or CCS_NORESIZE or CCS_NODIVIDER;
ListStyles: array[Boolean] of DWORD = (0, TBSTYLE_LIST);
FlatStyles: array[Boolean] of DWORD = (0, TBSTYLE_FLAT);
TransparentStyles: array[Boolean] of DWORD = (0, TBSTYLE_TRANSPARENT);
begin
FNewStyle := InitCommonControl(ICC_BAR_CLASSES);
inherited CreateParams(Params);
CreateSubClass(Params, TOOLBARCLASSNAME);
with Params do
begin
Style := Style or DefaultStyles or FlatStyles[FFlat] or ListStyles[FList]
or TransparentStyles[FTransparent];
if ShowCaptions then
Style := Style or TBSTYLE_TRANSPARENT;
WindowClass.style := WindowClass.style and
not Cardinal(CS_HREDRAW or CS_VREDRAW);
end;
end;
procedure TToolBar.CreateWnd;
const
TB_SETEXTENDEDSTYLE = (WM_USER + 84);
TB_GETEXTENDEDSTYLE = (WM_USER + 85);
TBSTYLE_EX_DRAWDDARROWS = $0001;
var
DisplayDC: HDC;
SaveFont, StockFont: HFONT;
TxtMetric: TTextMetric;
begin
inherited CreateWnd;
Perform(TB_SETEXTENDEDSTYLE, 0, Perform(TB_GETEXTENDEDSTYLE, 0, 0) or
TBSTYLE_EX_DRAWDDARROWS);
FOldHandle := 0;
StockFont := GetStockObject(SYSTEM_FONT);
if StockFont <> 0 then
begin
DisplayDC := GetDC(0);
if (DisplayDC <> 0) then
begin
SaveFont := SelectObject(DisplayDC, StockFont);
if (GetTextMetrics(DisplayDC, TxtMetric)) then
with TxtMetric do
FHeightMargin := tmHeight - tmInternalLeading - tmExternalLeading + 1;
SelectObject(DisplayDC, SaveFont);
ReleaseDC(0, DisplayDC);
end;
end;
RecreateButtons;
Invalidate;
end;
procedure TToolBar.CreateButtons(NewWidth, NewHeight: Integer);
function ToolButtonVisible: Boolean;
var
I: Integer;
Control: TControl;
begin
for I := 0 to FButtons.Count - 1 do
begin
Control := TControl(FButtons[I]);
if (Control is TToolButton) and ((csDesigning in ComponentState) or
Control.Visible) and not (TToolButton(Control).Style in
[tbsSeparator, tbsDivider]) then
begin
Result := True;
Exit;
end;
end;
Result := False;
end;
var
ImageWidth, ImageHeight: Integer;
I: Integer;
begin
Assert(False, 'Trace:IN TTOOLBAR.CREATEBUTTONS');
BeginUpdate;
try
HandleNeeded;
Perform(TB_BUTTONSTRUCTSIZE, SizeOf(TTBButton), 0);
Perform(TB_SETINDENT, FIndent, 0);
if FImages <> nil then
begin
ImageWidth := FImages.Width;
ImageHeight := FImages.Height;
end
else
if FDisabledImages <> nil then
begin
ImageWidth := FDisabledImages.Width;
ImageHeight := FDisabledImages.Height;
end
else
if FHotImages <> nil then
begin
ImageWidth := FHotImages.Width;
ImageHeight := FHotImages.Height;
end
else
begin
ImageWidth := 0;
ImageHeight := 0;
end;
Perform(TB_SETBITMAPSIZE, 0, MakeLParam(ImageWidth, ImageHeight));
if ShowCaptions and ToolButtonVisible then Dec(NewHeight, FHeightMargin);
if NewWidth <= 0 then NewWidth := 1;
if NewHeight <= 0 then NewHeight := 1;
Perform(TB_SETBUTTONSIZE, 0, MakeLParam(NewWidth, NewHeight));
FButtonWidth := NewWidth;
FButtonHeight := NewHeight;
finally
EndUpdate;
end;
Assert(False, Format('Trace:INTERNALBUTTONCOUNT = %d',[INTERNALBUTTONCOUNT]));
for I := 0 to InternalButtonCount - 1 do
begin
Perform(TB_DELETEBUTTON, 0, 0);
end;
UpdateButtons;
UpdateImages;
GetButtonSize(FButtonWidth, FButtonHeight);
end;
procedure TToolBar.RepositionButton(Index: Integer);
var
TBButton: TTBButton;
Button: TControl;
R: TRect;
AdjustY: Integer;
begin
if (csLoading in ComponentState) or
(Perform(TB_GETBUTTON, Index, Longint(@TBButton)) = 0) then
Exit;
if Perform(TB_GETITEMRECT, Index, Longint(@R)) <> 0 then
begin
Button := TControl(TBButton.dwData);
if Button is TToolButton then TToolButton(Button).BeginUpdate;
try
if not (Button is TToolButton) then
with Button do
begin
if Button is TWinControl then HandleNeeded;
BoundsRect := R;
if Height < R.Bottom - R.Top then
begin
AdjustY := (R.Bottom - R.Top - Height) div 2;
SetBounds(R.Left, R.Top + AdjustY, R.Right - R.Left, Height);
end;
end
else
Button.BoundsRect := R;
finally
if Button is TToolButton then TToolButton(Button).EndUpdate;
end;
end;
end;
procedure TToolBar.RepositionButtons(Index: Integer);
var
I: Integer;
begin
if (csLoading in ComponentState) or (FUpdateCount > 0) then Exit;
BeginUpdate;
try
for I := InternalButtonCount - 1 downto Index do RepositionButton(I);
finally
EndUpdate;
end;
end;
procedure TToolBar.GetButtonSize(var AWidth, AHeight: Integer);
var
LastIndex: Integer;
begin
if HandleAllocated then
begin
LastIndex := Perform(TB_GETBUTTONSIZE, 0, 0);
AHeight := LastIndex shr 16;
AWidth := LastIndex and $FFFF;
end;
end;
procedure TToolBar.SetButtonHeight(Value: Integer);
begin
if Value <> FButtonHeight then
begin
FButtonHeight := Value;
RecreateButtons;
end;
end;
procedure TToolBar.SetButtonWidth(Value: Integer);
begin
if Value <> FButtonWidth then
begin
FButtonWidth := Value;
RecreateButtons;
end;
end;
procedure TToolBar.InsertButton(Control: TControl);
var
FromIndex, ToIndex: Integer;
begin
if Control is TToolButton then
Begin
TToolButton(Control).FToolBar := Self;
TToolButton(Control).HandleNeeded;
end;
if not (csLoading in Control.ComponentState) then
begin
FromIndex := FButtons.IndexOf(Control);
if FromIndex >= 0 then
ToIndex := ReorderButton(Fromindex, Control.Left, Control.Top)
else
begin
ToIndex := ButtonIndex(FromIndex, Control.Left, Control.Top);
FButtons.Insert(ToIndex, Control);
UpdateItem(TB_INSERTBUTTON, ToIndex, ToIndex);
end;
end
else
begin
ToIndex := FButtons.Add(Control);
if TToolbutton(Control).Handle = 0 then TToolButton(Control).HandleNeeded;
UpdateButton(ToIndex);
end;
if Wrapable then
RepositionButtons(0)
else
RepositionButtons(ToIndex);
RecreateButtons;
end;
procedure TToolBar.RemoveButton(Control: TControl);
var
I : Integer;
Pos: Integer;
begin
I := FButtons.IndexOf(Control);
if I >= 0 then
begin
if Control is TToolButton then TToolButton(Control).FToolBar := nil;
Pos := FButtons.Remove(Control);
Perform(TB_DELETEBUTTON, Pos, 0);
ResizeButtons;
if Wrapable then
RepositionButtons(0)
else
RepositionButtons(Pos);
RecreateButtons;
end;
end;
function TToolBar.UpdateItem(Message, FromIndex, ToIndex: Integer): Boolean;
var
Control: TControl;
Button: TTBButton;
CaptionText: string;
Buffer: PChar;
begin
Control := TControl(FButtons[FromIndex]);
if Control is TToolButton then
with TToolButton(Control) do
begin
FillChar(Button, SizeOf(Button), 0);
if Style in [tbsSeparator, tbsDivider] then
begin
Button.iBitmap := Width;
Button.idCommand := -1;
end
else
begin
if ImageIndex < 0 then
Button.iBitmap := -2 else
Button.iBitmap := ImageIndex;
Button.idCommand := FromIndex;
end;
with Button do
begin
fsStyle := ButtonStyles[Style];
if AutoSize then
fsStyle := fsStyle or TBSTYLE_AUTOSIZE;
end;
Button.fsState := GetButtonState;
if FGrouped then Button.fsStyle := Button.fsStyle or TBSTYLE_GROUP;
Button.dwData := Longint(Control);
if ShowCaptions then
begin
if Caption <> '' then
CaptionText := Caption
else
{ Common control requries at least a space is used when showing button
captions. If any one button's caption is empty (-1) then none of
the buttons' captions will not be displayed. }
CaptionText := ' ';
Buffer:=StrAlloc(length(CaptionText)+2);
try
StrPCopy(Buffer, CaptionText);
{ TB_ADDSTRING requires two null terminators }
Buffer[Length(CaptionText) + 1] := #0;
Button.iString := Self.Perform(TB_ADDSTRING, 0, Longint(@Buffer));
finally
StrDispose(Buffer);
end;
end
else
Button.iString := -1;
end
else
begin
FillChar(Button, SizeOf(Button), 0);
Button.fsStyle := ButtonStyles[tbsSeparator];
Button.iBitmap := Control.Width;
Button.idCommand := -1;
if not Control.Visible and not (csDesigning in Control.ComponentState) then
Button.fsState := Button.fsState or ButtonStates[tbsHidden];
Button.dwData := Longint(Control);
Button.iString := -1;
end;
Result := Self.Perform(Message, ToIndex, Integer(@Button)) <> 0;
end;
function TToolBar.UpdateItem2(Message, FromIndex, ToIndex: Integer): Boolean;
var
Control: TControl;
Button: TTBButtonInfo;
CaptionText: string;
Buffer: PChar;
begin
Control := TControl(FButtons[FromIndex]);
FillChar(Button, SizeOf(Button), 0);
Button.cbSize := SizeOf(Button);
if Control is TToolButton then
with TToolButton(Control) do
begin
Button.dwMask := TBIF_STATE or TBIF_STYLE or TBIF_LPARAM or TBIF_COMMAND
or TBIF_SIZE;
if Style in [tbsSeparator, tbsDivider] then
begin
Button.idCommand := -1;
end
else
begin
Button.dwMask := Button.dwMask or TBIF_IMAGE;
if ImageIndex < 0 then
Button.iImage := -2 else
Button.iImage := ImageIndex;
Button.idCommand := FromIndex;
end;
with Button do
begin
cx := Width;
fsStyle := ButtonStyles[Style];
if AutoSize then fsStyle := fsStyle or TBSTYLE_AUTOSIZE;
if Grouped then Button.fsStyle := Button.fsStyle or TBSTYLE_GROUP;
end;
Button.fsState := GetButtonState;
Button.lParam := Longint(Control);
if ShowCaptions then
begin
if Caption <> '' then
CaptionText := Caption
else
{ Common control requries at least a space is used when showing button
captions. If any one button's caption is empty (-1) then none of
the buttons' captions will not be displayed. }
CaptionText := ' ';
Buffer:=StrAlloc(length(CaptionText)+2);
try
StrPCopy(Buffer, CaptionText);
{ TB_ADDSTRING requires two null terminators }
Buffer[Length(CaptionText) + 1] := #0;
//Button.iString := Self.Perform(TB_ADDSTRING, 0, Longint(@Buffer));
finally
StrDispose(Buffer);
end;
Button.pszText := Buffer;
Button.cchText := Length(CaptionText);
Button.dwMask := Button.dwMask or TBIF_TEXT;
end
else
begin
Button.pszText := nil;
Button.cchText := 0;
end;
if Style in [tbsSeparator, tbsDivider] then
begin
with Button do
begin
dwMask := TBIF_STYLE or TBIF_STATE or TBIF_LPARAM;
fsState := TBSTATE_ENABLED or TBSTATE_WRAP;
fsStyle := TBSTYLE_BUTTON;
end;
end;
end
else
begin
Button.dwMask := TBIF_TEXT or TBIF_STATE or TBIF_STYLE or TBIF_LPARAM or
TBIF_COMMAND or TBIF_SIZE;
Button.fsStyle := ButtonStyles[tbsSeparator];
Button.cx := Control.Width;
Button.idCommand := -1;
Button.lParam := Longint(Control);
Button.pszText := nil;
Button.cchText := 0;
end;
Result := Self.Perform(Message, ToIndex, Integer(@Button)) <> 0;
end;
function TToolBar.RefreshButton(Index: Integer): Boolean;
var
Style: Longint;
begin
if not (csLoading in ComponentState) and (FUpdateCount = 0) then
begin
BeginUpdate;
try
Style := GetWindowLong(Handle, GWL_STYLE);
SetWindowLong(Handle, GWL_STYLE, Style and not WS_VISIBLE);
try
Result := (Index < InternalButtonCount) and
UpdateItem(TB_DELETEBUTTON, Index, Index) and
UpdateItem(TB_INSERTBUTTON, Index, Index);
finally
SetWindowLong(Handle, GWL_STYLE, Style);
end;
finally
EndUpdate;
end;
end
else
Result := False;
end;
procedure TToolBar.UpdateButton(Index: Integer);
var
Style: Longint;
begin
if (csLoading in ComponentState) or (FUpdateCount > 0) then Exit;
BeginUpdate;
try
HandleNeeded;
Style := GetWindowLong(Handle, GWL_STYLE);
SetWindowLong(Handle, GWL_STYLE, Style and not WS_VISIBLE);
try
if Index < InternalButtonCount then
UpdateItem2(TB_SETBUTTONINFO, Index, Index)
else
UpdateItem(TB_INSERTBUTTON, Index, Index);
finally
SetWindowLong(Handle, GWL_STYLE, Style);
end;
finally
EndUpdate;
end;
end;
procedure TToolBar.UpdateButtons;
const
BlankButton: TTBButton = (iBitmap: 0; idCommand: 0; fsState: 0;
fsStyle: TBSTYLE_BUTTON; bReserved: (0, 0); dwData: 0; iString: 0);
var
I: Integer;
Count: Integer;
Style: Longint;
begin
Assert(False, 'Trace:IN TTOOLBAR.UPDATEBUTTONS');
BeginUpdate;
try
HandleNeeded;
Style := GetWindowLong(Handle, GWL_STYLE);
SetWindowLong(Handle, GWL_STYLE, Style and not WS_VISIBLE);
try
Count := InternalButtonCount;
Assert(False, Format('Trace:COUNT = %d --FBUTTONS.COUNT = %d',[COUNT,FButtons.Count]));
for I := 0 to FButtons.Count - 1 do
begin
if I < Count then
Begin
Assert(False, Format('Trace:????CALLING UPDATEITEM2??????????? I , Count = %d,%d',[I,Count]));
UpdateItem2(TB_SETBUTTONINFO, I, I)
end
else
Begin
Assert(False, Format('Trace:????INSERT BUTTON HERE??????????? I , Count = %d,%d',[I,Count]));
UpdateItem(TB_INSERTBUTTON, I, I);
End;
end;
finally
SetWindowLong(Handle, GWL_STYLE, Style);
end;
finally
EndUpdate;
end;
RepositionButtons(0);
end;
procedure TToolBar.UpdateButtonState(Index: Integer);
var
TBButton: TTBButton;
begin
if (Perform(TB_GETBUTTON, Index, Integer(@TBButton)) <> 0) then
with TToolButton(TBButton.dwData) do
begin
SetButtonState(TBButton.fsState);
Self.Perform(TB_SETSTATE, Index, MakeLong(GetButtonState, 0));
end;
end;
procedure TToolBar.UpdateButtonStates;
var
I: Integer;
begin
for I := 0 to FButtons.Count - 1 do
if TControl(FButtons[I]) is TToolButton then
UpdateButtonState(I);
end;
procedure TToolBar.SetShowCaptions(Value: Boolean);
begin
if FShowCaptions <> Value then
begin
FShowCaptions := Value;
if not (csLoading in ComponentState) then
RecreateWnd;
AdjustSize;
end;
end;
function TToolBar.GetButton(Index: Integer): TToolButton;
begin
Result := TToolButton(FButtons[Index]);
end;
function TToolBar.GetButtonCount: Integer;
begin
Result := FButtons.Count;
end;
function TToolBar.GetRowCount: Integer;
begin
Result := Perform(TB_GETROWS, 0, 0);
end;
procedure TToolBar.SetList(Value: Boolean);
begin
if FList <> Value then
begin
FList := Value;
RecreateWnd;
end;
end;
procedure TToolBar.SetFlat(Value: Boolean);
begin
//GTK does not support flat/nof-flat yet but I add the code to stay compatable
if FFlat <> Value then
begin
FFlat := Value;
RecreateWnd;
end;
end;
procedure TToolBar.SetTransparent(Value: Boolean);
begin
if FTransparent <> Value then
begin
FTransparent := Value;
RecreateWnd;
end;
end;
procedure TToolBar.SetWrapable(Value: Boolean);
begin
if FWrapable <> Value then
begin
FWrapable := Value;
if AutoSize then AdjustSize;
end;
end;
procedure TToolBar.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
begin
if AComponent = FImages then Images := nil;
if AComponent = FHotImages then HotImages := nil;
if AComponent = FDisabledImages then DisabledImages := nil;
end;
end;
procedure TToolBar.LoadImages(AImages: TCustomImageList);
var
AddBitmap: TTBAddBitmap;
ReplaceBitmap: TTBReplaceBitmap;
NewHandle: HBITMAP;
function GetImageBitmap(ImageList: TCustomImageList): HBITMAP;
var
//I: Integer;
Bitmap: TBitmap;
R: TRect;
begin
Bitmap := TBitmap.Create;
try
Bitmap.Width := ImageList.Width * ImageList.Count;
Bitmap.Height := ImageList.Height;
R := Rect(0,0,Width,Height);
with Bitmap.Canvas do
begin
Brush.Color := clBtnFace;
FillRect(R);
end;
{TODO: FINISH THIS by adding this function. IMAGELIST_DRAW
for I := 0 to ImageList.Count - 1 do
ImageList_Draw(ImageList.Handle, I, Bitmap.Canvas.Handle,I * ImageList.Width, 0, ILD_TRANSPARENT);
}
Result := Bitmap.ReleaseHandle;
finally
Bitmap.Free;
end;
end;
begin
if AImages <> nil then
NewHandle := GetImageBitmap(AImages)
else
with TBitmap.Create do
try
Assign(FNullBitmap);
NewHandle := ReleaseHandle;
finally
Free;
end;
if FOldHandle = 0 then
begin
AddBitmap.hInst := 0;
AddBitmap.nID := NewHandle;
Perform(TB_ADDBITMAP, ButtonCount, Longint(@AddBitmap));
end
else
begin
with ReplaceBitmap do
begin
hInstOld := 0;
nIDOld := FOldHandle;
hInstNew := 0;
nIDNew := NewHandle;
nButtons := ButtonCount;
end;
Perform(TB_REPLACEBITMAP, 0, Longint(@ReplaceBitmap));
if FOldHandle <> 0 then DeleteObject(FOldHandle);
end;
FOldHandle := NewHandle;
end;
procedure TToolBar.UpdateImages;
begin
if FNewStyle then
begin
if FImages <> nil then SetImageList(FImages.Handle);
if FDisabledImages <> nil then SetDisabledImageList(FDisabledImages.Handle);
if FHotImages <> nil then SetHotImageList(FHotImages.Handle);
end
else
if HandleAllocated then LoadImages(FImages);
end;
procedure TToolBar.ImageListChange(Sender: TObject);
begin
if HandleAllocated and (Sender = Images) then RecreateButtons;
end;
procedure TToolBar.SetImageList(Value: HImageList);
begin
if HandleAllocated then Perform(TB_SETIMAGELIST, 0, Value);
Invalidate;
end;
procedure TToolBar.SetImages(Value: TCustomImageList);
begin
// if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink);
FImages := Value;
if FImages <> nil then
begin
// FImages.RegisterChanges(FImageChangeLink);
FImages.FreeNotification(Self);
end
else
SetImageList(0);
RecreateButtons;
end;
procedure TToolBar.DisabledImageListChange(Sender: TObject);
begin
if HandleAllocated and (Sender = DisabledImages) then RecreateButtons;
end;
procedure TToolBar.SetDisabledImageList(Value: HImageList);
begin
if HandleAllocated then Perform(TB_SETDISABLEDIMAGELIST, 0, Value);
Invalidate;
end;
procedure TToolBar.SetDisabledImages(Value: TCustomImageList);
begin
// if FDisabledImages <> nil then FDisabledImages.UnRegisterChanges(FDisabledImageChangeLink);
FDisabledImages := Value;
if FDisabledImages <> nil then
begin
// FDisabledImages.RegisterChanges(FDisabledImageChangeLink);
FDisabledImages.FreeNotification(Self);
end
else
SetDisabledImageList(0);
RecreateButtons;
end;
procedure TToolBar.HotImageListChange(Sender: TObject);
begin
if HandleAllocated and (Sender = HotImages) then RecreateButtons;
end;
procedure TToolBar.SetHotImageList(Value: HImageList);
begin
if HandleAllocated then Perform(TB_SETHOTIMAGELIST, 0, Value);
Invalidate;
end;
procedure TToolBar.SetHotImages(Value: TCustomImageList);
begin
// if FHotImages <> nil then FHotImages.UnRegisterChanges(FHotImageChangeLink);
FHotImages := Value;
if FHotImages <> nil then
begin
// FHotImages.RegisterChanges(FHotImageChangeLink);
FHotImages.FreeNotification(Self);
end
else
SetHotImageList(0);
RecreateButtons;
end;
procedure TToolBar.SetIndent(Value: Integer);
begin
if FIndent <> Value then
begin
FIndent := Value;
RecreateWnd;
end;
end;
procedure TToolBar.RecreateButtons;
begin
if not (csLoading in ComponentState) or HandleAllocated then
begin
CreateButtons(FButtonWidth, FButtonHeight);
ResizeButtons;
end;
end;
procedure TToolBar.WMKeyDown(var Message: TLMKeyDown);
var
Item: Integer;
Button: TToolButton;
//P: TPoint;
begin
if FInMenuLoop then
begin
Item := Perform(TB_GETHOTITEM, 0, 0);
case Message.CharCode of
VK_RETURN, VK_DOWN:
begin
if (Item > -1) and (Item < FButtons.Count) then
begin
Button := TToolButton(FButtons[Item]);
Button.ClientToScreen(Point(1, 1));
ClickButton(Button);
end;
{ Prevent default processing }
if Message.CharCode = VK_DOWN then Exit;
end;
VK_ESCAPE: CancelMenu;
end;
end;
inherited WMKeyDown(Message);
end;
procedure TToolBar.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
I: Integer;
Control: TControl;
begin
for I := 0 to FButtons.Count - 1 do Proc(TComponent(FButtons[I]));
for I := 0 to ControlCount - 1 do
begin
Control := Controls[I];
if (Control.Owner = Root) and (FButtons.IndexOf(Control) = -1) then Proc(Control);
end;
end;
procedure TToolBar.Loaded;
var
I: Integer;
begin
RecreateButtons;
{ Make sure we dock controls after streaming }
for I := 0 to ControlCount - 1 do
Controls[I].HostDockSite := Self;
inherited Loaded;
ResizeButtons;
RepositionButtons(0);
end;
procedure TToolBar.BeginUpdate;
begin
Inc(FUpdateCount);
end;
procedure TToolBar.EndUpdate;
begin
Dec(FUpdateCount);
end;
procedure TToolBar.ResizeButtons;
begin
if not (csLoading in ComponentState) and HandleAllocated then
begin
Perform(TB_AUTOSIZE, 0, 0);
if AutoSize then AdjustSize;
end;
end;
function TToolBar.InternalButtonCount: Integer;
begin
// Result := Perform(TB_BUTTONCOUNT, 0, 0);
Result := CNSendMessage(LM_TB_BUTTONCOUNT,Self,Nil);
end;
function TToolBar.ButtonIndex(OldIndex, ALeft, ATop: Integer): Integer;
var
Dist, Tmp, Head, Tail: Integer;
Control: TControl;
TEmpIndex : Integer;
begin
if (OldIndex >= 0) and (FButtons.Count <= 1) then
begin
Result := OldIndex;
Exit;
end;
{ Find row closest to ATop }
Result := 0;
if FButtons.Count = 0 then Exit;
Tmp := 0;
Head := 0;
Tail := 0;
Dist := MaxInt;
while (Dist > 0) and (Result < FButtons.Count) do
begin
if Result <> OldIndex then
begin
Control := TControl(FButtons[Result]);
if (Control is TToolButton) and TToolButton(Control).Wrap or
(Result = FButtons.Count - 1) then
begin
if Abs(ATop - Control.Top) < Dist then
begin
Dist := Abs(ATop - Control.Top);
Head := Tmp;
Tail := Result;
end;
Tmp := Result + 1;
end;
end
else
Tail := Result;
Inc(Result);
end;
{ Find button on Row closest to ALeft }
for TempIndex := Head to Tail do
if (TempIndex <> OldIndex) then
if FButtons[Result] <> nil then
if (ALeft <= TControl(FButtons[Result]).Left) then
Break;
{ Return old position if new position is last on the row and old position
was already the last on the row. }
if (TempIndex = OldIndex + 1) and (OldIndex in [Head..Tail]) then
Result := OldIndex
else
Result := TempIndex;
end;
function TToolBar.ReorderButton(OldIndex, ALeft, ATop: Integer): Integer;
var
Control: TControl;
begin
Result := ButtonIndex(OldIndex, ALeft, ATop);
if Result <> OldIndex then
begin
{ If we are inserting to the right of our deletion then account for shift }
if OldIndex < Result then Dec(Result);
Control := TControl(FButtons[OldIndex]);
FButtons.Delete(OldIndex);
FButtons.Insert(Result, Control);
BeginUpdate;
try
Perform(TB_DELETEBUTTON, OldIndex, 0);
UpdateItem(TB_INSERTBUTTON, Result, Result);
finally
EndUpdate;
end;
end;
end;
procedure TToolBar.AdjustControl(Control: TControl);
var
I, Pos: Integer;
R: TRect;
Reordered, NeedsUpdate: Boolean;
begin
Pos := FButtons.IndexOf(Control);
if Pos = -1 then Exit;
Reordered := ReorderButton(Pos, Control.Left, Control.Top) <> Pos;
NeedsUpdate := False;
if Reordered then
begin
I := FButtons.IndexOf(Control);
if I < Pos then Pos := I;
end
else if Perform(TB_GETITEMRECT, Pos, Longint(@R)) <> 0 then
begin
NeedsUpdate := Control.Width <> R.Right - R.Left;
Reordered := NeedsUpdate;
end;
if (csDesigning in ComponentState) and (Control.Height <> ButtonHeight) then
ButtonHeight := Control.Height
else
if Reordered then
begin
if NeedsUpdate then
RefreshButton(Pos);
ResizeButtons;
RepositionButtons(0);
end
else
RepositionButton(Pos);
end;
procedure TToolBar.AlignControls(AControl: TControl; var Rect: TRect);
begin
if FUpdateCount > 0 then Exit;
if AControl = nil then
RepositionButtons(0)
else if not (AControl is TToolButton) then
AdjustControl(AControl);
end;
procedure TToolBar.ChangeScale(M, D: Integer);
begin
end;
procedure TToolBar.WMEraseBkgnd(var Message: TLMEraseBkgnd);
begin
if not Transparent then
inherited WMEraseBkgnd(Message)
else
DefaultHandler(Message);
end;
procedure TToolBar.WMGetDlgCode(var Message: TLMessage);
begin
if FInMenuLoop then
Message.Result := DLGC_WANTARROWS;
end;
procedure TToolBar.WMGetText(var Message: TLMGetText);
begin
//This should NOT be needed in LCL
end;
procedure TToolBar.WMGetTextLength(var Message: TLMGetTextLength);
begin
Message.Result := Length(FCaption);
end;
procedure TToolBar.WMSetText(var Message: TLMSetText);
begin
with Message do
SetString(FCaption, Text, StrLen(pchar(Text)));
end;
procedure TToolBar.WMNotifyFormat(var Message: TLMessage);
begin
//TODO: WMNOTIFYFORMAT
end;
procedure TToolBar.WMSize(var Message: TLMSize);
var
W, H: Integer;
begin
inherited WMSize(Message);
if not AutoSize then
begin
W := Width;
H := Height;
WrapButtons(W, H);
end;
end;
procedure TToolBar.WMSysChar(var Message: TLMSysChar);
var
Form: TCustomForm;
begin
Form := GetParentForm(Self);
if Form <> nil then
begin
Form.Dispatch(Message);
Exit;
end;
end;
procedure TToolBar.WMWindowPosChanged(var Message: TLMWindowPosChanged);
begin
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:!!!!!!!!!TODO: FINISH WMWindowPosChanged in toolbar.inc!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
end;
procedure TToolBar.WMWindowPosChanging(var Message: TLMWindowPosChanging);
begin
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:!!!!!!!!!TODO: FINISH WMWindowPosChanging in toolbar.inc!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
end;
function TToolBar.WrapButtons(var NewWidth, NewHeight: Integer): Boolean;
Begin
//TODO: TToolbar.WrapButtons
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:!!!!!!!!!TODO: FINISH Wrapbuttons in toolbar.inc!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
result := true;
end;
function TToolBar.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
Result := WrapButtons(NewWidth, NewHeight);
end;
procedure TToolBar.CMControlChange(var Message: TCMControlChange);
begin
Assert(False, 'Trace:TOOLBAR recieved a CMCONTROLCHANGED event');
HandleNeeded;
with Message do
if Inserting then
InsertButton(Control)
else
RemoveButton(Control);
end;
procedure TToolBar.CNChar(var Message: TLMChar);
begin
if FInMenuLoop and not (csDesigning in ComponentState) then
with Message do
if Perform(CM_DIALOGCHAR, CharCode, KeyData) <> 0 then
Result := 1;
end;
procedure TToolBar.CMDialogChar(var Message: TCMDialogChar);
var
Button: TToolButton;
begin
if Enabled and Showing and ShowCaptions then
begin
Button := FindButtonFromAccel(Message.CharCode);
if Button <> nil then
begin
{ Display a drop-down menu after hitting the accelerator key if IE3
is installed. Otherwise, fire the OnClick event for IE4. We do this
because the IE4 version of the drop-down metaphor is more complete,
allowing the user to click a button OR drop-down its menu. }
if (Button.Style <> tbsDropDown) and
((Button.DropdownMenu <> nil) or (Button.MenuItem <> nil)) then
TrackMenu(Button)
else
Button.Click;
Message.Result := 1;
Exit;
end;
end;
end;
procedure TToolBar.CMEnabledChanged(var Message: TLMessage);
begin
Broadcast(Message);
end;
procedure TToolBar.CMColorChanged(var Message: TLMessage);
begin
RecreateWnd;
end;
procedure TToolBar.CMParentColorChanged(var Message: TLMessage);
begin
if Transparent then Invalidate;
end;
procedure TToolBar.CNSysKeyDown(var Message: TLMSysKeyDown);
begin
if (Message.CharCode = VK_MENU) then
CancelMenu;
end;
procedure TToolBar.CMSysFontChanged(var Message: TLMessage);
begin
RecreateWnd;
end;
procedure TToolBar.CNDropDownClosed(var Message: TLMessage);
begin
ClearTempMenu;
FCaptureChangeCancels := True;
end;
procedure TToolBar.CNNotify(var Message: TLMNotify);
var
Button: TToolButton;
begin
with Message do
case NMHdr^.code of
TBN_DROPDOWN:
with PNMToolBar(NMHdr)^ do
{ We can safely assume that a TBN_DROPDOWN message was generated by a
TToolButton and not any TControl. }
if Perform(TB_GETBUTTON, iItem, Longint(@tbButton)) <> 0 then
begin
Button := TToolButton(tbButton.dwData);
if Button <> nil then
Button.CheckMenuDropDown;
end;
end;
end;
procedure TToolBar.WndProc(var Message: TLMessage);
Begin
//TODO: TToolbar.WndProc
case Message.msg of
TB_INSERTBUTTON : Assert(False, 'Trace:!!!!!!!!!!!!!!!!!TB_INSERTBUTTON!!!!!!!!!!!!!!');
LM_NOTIFYFORMAT : Assert(False, 'Trace:!!!!!!!!!!!!!!!!!LM_NOTIFYFORMAT!!!!!!!!!!!!!!');
LM_EXPOSEEVENT : Assert(False, 'Trace:!!!!!!!!!!!!!!!!!ExposeEvent!!!!!!!!!!!!!!');
LM_SETSELTEXT : Assert(False, 'Trace:!!!!!!!!!!!!!!!!!LM_SETSELTEXT!!!!!!!!!!!!!!');
LM_PAINT : Assert(False, 'Trace:!!!!!!!!!!!!!!!!!LM_PAINT!!!!!!!!!!!!!!');
LM_CONFIGUREEVENT : Assert(False, 'Trace:!!!!!!!!!!!!!!!!!LM_CONFIGUREEVENT!!!!!!!!!!!!!!');
LM_KILLWORD : Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!!!LM_KILLWORD!!!!!!!!!!!!!!!!!!!!');
LM_SETSELMODE : Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!!!LM_SETSELMODE!!!!!!!!!!!!!!!!');
LM_SHOWMODAL : Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!!!!!LM_SHOWMODAL!!!!!!!!!!!!!!!!!!!');
end;
case Message.msg of
TB_INSERTBUTTON : Begin
CNSendMessage(LM_INSERTTOOLBUTTON,TControl(TTBButton(Pointer(Message.lParam)^).dwData),nil);
end;
TB_DELETEBUTTON : Begin
CNSendMessage(LM_DELETETOOLBUTTON,TControl(FButtons[Message.wparam]),nil);
end;
end;
inherited WndProc(Message);
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 := TToolButton(FButtons[I]);
if Result.Visible and Result.Enabled and IsAccel(Accel, Result.Caption) then
Exit;
end;
Result := nil;
end;
function ToolMenuGetMsgHook(Code: Integer; WParam: Longint;
var Msg: TMsg): Longint; stdcall;
Begin
// ToDo
Result:=0;
end;
procedure InitToolMenuHooks;
begin
end;
procedure ReleaseToolMenuHooks;
begin
end;
function ToolMenuKeyMsgHook(Code: Integer; WParam: Longint;
var Msg: TMsg): Longint; stdcall;
begin
// ToDo
Result:=0;
end;
procedure InitToolMenuKeyHooks;
begin
end;
procedure ReleaseToolMenuKeyHooks;
begin
end;
procedure TToolBar.ClearTempMenu;
var
I: Integer;
Item: TMenuItem;
begin
if (FButtonMenu <> nil) and (FMenuButton <> nil) and
(FMenuButton.MenuItem <> nil) and (FTempMenu <> nil) then
begin
for I := FTempMenu.Items.Count - 1 downto 0 do
begin
Item := FTempMenu.Items[I];
FTempMenu.Items.Delete(I);
FButtonMenu.Insert(0, Item);
end;
FTempMenu.Free;
FTempMenu := nil;
FMenuButton := nil;
FButtonMenu := nil;
end;
end;
function TToolBar.CheckMenuDropdown(Button: TToolButton): Boolean;
var
Hook: Boolean;
//Menu: TMenu;
Item: TMenuItem;
I: Integer;
//ParentMenu: TMenu;
APoint: TPoint;
begin
Result := False;
if Button = nil then Exit;
FCaptureChangeCancels := False;
try
if Button.DropdownMenu <> nil then
FTempMenu := Button.DropdownMenu
else if Button.MenuItem <> nil then
begin
//TODO: FINISH MENUITEM.CLICK
// Button.MenuItem.Click;
ClearTempMenu;
FTempMenu := TPopupMenu.Create(Self);
//TODO: FINISH Menu BiDiMode and HelpContext and Images 12/21/99
{
ParentMenu := Button.MenuItem.GetParentMenu;
if ParentMenu <> nil then
FTempMenu.BiDiMode := ParentMenu.BiDiMode;
FTempMenu.HelpContext := Button.MenuItem.HelpContext;
FTempMenu.TrackButton := tbLeftButton;
Menu := Button.MenuItem.GetParentMenu;
if Menu <> nil then
FTempMenu.Images := Menu.Images;
}
FButtonMenu := Button.MenuItem;
for I := FButtonMenu.Count - 1 downto 0 do
begin
Item := FButtonMenu.Items[I];
FButtonMenu.Delete(I);
FTempMenu.Items.Insert(0, Item);
end;
end
else
Exit;
//TODO: Finish SENDCANCELMODE
// SendCancelMode(nil);
//TODO: Add PopupComponent to Menu
// FTempMenu.PopupComponent := Self;
Hook := Button.Grouped or (Button.MenuItem <> nil);
if Hook then
begin
//MenuButtonIndex := Button.Index;
//MenuToolBar := Self;
InitToolMenuHooks;
end;
Perform(TB_SETHOTITEM, -1, 0);
try
APoint := Button.ClientToScreen(Point(0, Button.ClientHeight));
if FTempMenu.IsRightToLeft then Inc(APoint.X, Button.Width);
//TODO: finish Menu.popup
// FTempMenu.Popup(APoint.X, APoint.Y);
finally
if Hook then ReleaseToolMenuHooks;
end;
FMenuButton := Button;
if StillModal then
Perform(TB_SETHOTITEM, Button.Index, 0);
Result := True;
finally
//TODO: Add POSTMESSAGE
// PostMessage(Handle, CN_DROPDOWNCLOSED, 0, 0);
end;
end;
procedure TToolBar.WMSysCommand(var Message: TLMSysCommand);
var
Button: TToolButton;
begin
{ Enter menu loop if only the Alt key is pressed -- ignore Alt-Space and let
the default processing show the system menu. }
if not FInMenuLoop and Enabled and Showing and ShowCaptions then
with Message do
if (CmdType and $FFF0 = SC_KEYMENU) and (Key <> VK_SPACE) and
(Key <> Word(ord('-'))) and (GetCapture = 0) then
begin
if Key = 0 then
Button := nil else
Button := FindButtonFromAccel(Key);
if (Key = 0) or (Button <> nil) then
begin
TrackMenu(Button);
Result := 1;
Exit;
end;
end;
end;
procedure TToolBar.ClickButton(Button: TToolButton);
//var
// P: TPoint;
begin
FCaptureChangeCancels := False;
{P := }Button.ClientToScreen(Point(0, 0));
//TODO: Add POSTMESSAGE
// PostMessage(Handle, LM_LBUTTONDOWN, MK_LBUTTON,
// Longint(PointToSmallPoint(ScreenToClient(P))));
end;
procedure TToolBar.InitMenu(Button: TToolButton);
begin
//MenuToolBar2 := Self;
MouseCapture := True;
InitToolMenuKeyHooks;
if Button <> nil then
begin
Perform(TB_SETHOTITEM, Button.Index, 0);
ClickButton(Button);
end
else
Perform(TB_SETHOTITEM, 0, 0);
if Button = nil then
FCaptureChangeCancels := True;
end;
procedure TToolBar.CancelMenu;
begin
if FInMenuLoop then
begin
ReleaseToolMenuKeyHooks;
MouseCapture := False;
end;
FInMenuLoop := False;
FCaptureChangeCancels := False;
Perform(TB_SETHOTITEM, -1, 0);
end;
function TToolBar.TrackMenu(Button: TToolButton): Boolean;
begin
if FInMenuLoop then
begin
if Button <> nil then
begin
ClickButton(Button);
Result := True;
end
else
Result := False;
Exit;
end;
InitMenu(Button);
try
FInMenuLoop := True;
{ repeat
if Application.Terminated then
FInMenuLoop := False;
until not FInMenuLoop;
}
finally
CancelMenu;
end;
Result := FMenuResult;
end;
{ =============================================================================
$Log$
Revision 1.6 2002/05/10 06:05:55 lazarus
MG: changed license to LGPL
Revision 1.5 2001/09/30 08:34:50 lazarus
MG: fixed mem leaks and fixed range check errors
Revision 1.4 2001/06/14 23:13:30 lazarus
MWE:
* Fixed some syntax errors for the latest 1.0.5 compiler
Revision 1.3 2001/06/14 14:57:58 lazarus
MG: small bugfixes and less notes
Revision 1.2 2001/03/12 12:17:01 lazarus
MG: fixed random function results
Revision 1.1 2000/07/13 10:28:28 michael
+ Initial import
Revision 1.3 2000/05/30 22:28:41 lazarus
MWE:
Applied patches from Vincent Snijders:
+ Added GetWindowRect
* Fixed horz label alignment
+ Added vert label alignment
Revision 1.2 2000/05/09 02:07:40 lazarus
Replaced writelns with Asserts. CAW
Revision 1.1 2000/04/02 20:49:57 lazarus
MWE:
Moved lazarus/lcl/*.inc files to lazarus/lcl/include
Revision 1.9 2000/03/30 18:07:55 lazarus
Added some drag and drop code
Added code to change the unit name when it's saved as a different name. Not perfect yet because if you are in a comment it fails.
Shane
Revision 1.8 1999/12/30 19:49:07 lazarus
*** empty log message ***
Revision 1.6 1999/12/29 20:38:23 lazarus
Modified the toolbar so it now displays itself. However, I can only add one button at this point. I will fix that soon....
Shane
Revision 1.5 1999/12/23 19:50:54 lazarus
Working on the toolbar again. Haven't been able to get it to display at all yet.
gtkobject.inc - removed IntCNSendMessage and IntCNSendMessage2
WinControl.inc - addded code to InsertControl so when a control is added to a parent's control list, a CMCONTROLCHANGED message is sent. This way the parent can react to the addition.
Shane
Revision 1.1 1999/12/22 14:33:36 lazarus
Initial addition of a few new files.
Shane
Revision 1.1 1999/12/08 16:22:19 lazarus
Templates initially created SM
}
Reference in New Issue View Git Blame Copy Permalink