paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-14 03:19:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

added child-parent checks

Browse Source 
git-svn-id: trunk@5218 -
This commit is contained in:
mattias 2004-02-22 10:43:20 +00:00
parent b65e8867cf
commit 39a7a94021
18 changed files with 343 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
lcl/buttons.pp
View File

@ -79,6 +79,7 @@ type
property OnMouseLeave : TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
procedure SetParent(AParent: TWinControl); override;
procedure SetText(const Value: TCaption); override;
function ChildClassAllowed(ChildClass: TClass): boolean; override;
public
constructor Create(AOwner: TComponent); override;
published
@ -331,6 +332,9 @@ end.
{ =============================================================================
$Log$
Revision 1.59 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.58 2004/02/10 00:05:03 mattias
TSpeedButton now uses MaskBlt

20
lcl/comctrls.pp
View File

@ -799,7 +799,9 @@ type
FLastButtonDrawFlags: Integer;
FMarked: Boolean;
FMenuItem: TMenuItem;
FMouseInControl: boolean;
FStyle: TToolButtonStyle;
FState: TToolButtonState;
FUpdateCount: Integer;
FWrap: Boolean;
function GetIndex: Integer;
@ -816,7 +818,10 @@ type
procedure SetMenuItem(Value: TMenuItem);
procedure SetStyle(Value: TToolButtonStyle);
procedure SetWrap(Value: Boolean);
procedure SetMouseInControl(NewMouseInControl: Boolean);
procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
procedure CMMouseEnter(var Message: TLMessage); message CM_MouseEnter;
procedure CMMouseLeave(var Message: TLMessage); message CM_MouseLeave;
protected
FToolBar: TToolBar;
function GetActionLinkClass: TControlActionLinkClass; override;
@ -838,6 +843,8 @@ type
public
constructor Create(TheOwner: TComponent); override;
function CheckMenuDropdown: Boolean; dynamic;
procedure GetCurrentIcon(var ImageList: TCustomImageList;
var Index: integer); virtual;
property Index: Integer read GetIndex;
published
property Action;
@ -884,11 +891,19 @@ type
);
TToolBarFlags = set of TToolBarFlag;
TToolBarButtonStyle = (
tbbsText,
tbbsIcon,
tbbsIconLeftOfText,
tbbsIconAboveText
);
TToolBar = class(TToolWindow)
private
FButtonHeight: Integer;
FButtons: TList;
FButtonStyle: TToolBarButtonStyle;
FButtonWidth: Integer;
FDisabledImageChangeLink: TChangeLink;
FDisabledImages: TCustomImageList;
@ -911,6 +926,7 @@ type
function GetButton(Index: Integer): TToolButton;
function GetButtonCount: Integer;
procedure SetButtonHeight(const AValue: Integer);
procedure SetButtonStyle(const AValue: TToolBarButtonStyle);
procedure SetButtonWidth(const AValue: Integer);
procedure SetDisabledImages(const AValue: TCustomImageList);
procedure SetFlat(const AValue: Boolean);
@ -960,6 +976,7 @@ type
property BorderWidth;
property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 22;
property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 23;
property ButtonStyle: TToolBarButtonStyle read FButtonStyle write SetButtonStyle default tbbsIcon;
property Caption;
property Color;
property Ctl3D;
@ -2232,6 +2249,9 @@ end.
{ =============================================================================
$Log$
Revision 1.111 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.110 2004/02/21 15:37:33 mattias
moved compiler options to project menu, added -CX for smartlinking

8
lcl/controls.pp
View File

@ -843,6 +843,7 @@ type
procedure CMVisibleChanged(var Message : TLMessage); message CM_VISIBLECHANGED;
procedure Changed;
function GetPalette: HPalette; virtual;
function ChildClassAllowed(ChildClass: TClass): boolean; virtual;
procedure Loaded; override;
procedure AssignTo(Dest: TPersistent); override;
procedure BeginAutoDrag; dynamic;
@ -952,6 +953,9 @@ type
procedure Repaint; virtual;
Procedure Invalidate; virtual;
procedure AddControl; virtual;
function CheckChildClassAllowed(ChildClass: TClass;
ExceptionOnInvalid: boolean): boolean;
procedure CheckNewParent(AParent: TWinControl); virtual;
Procedure DragDrop(Source: TObject; X,Y: Integer); Dynamic;
procedure SendToBack;
procedure SetBounds(aLeft, aTop, aWidth, aHeight: integer); virtual;
@ -1286,6 +1290,7 @@ type
procedure DoSetBounds(ALeft, ATop, AWidth, AHeight : integer); override;
procedure DoAutoSize; Override;
procedure GetChildren(Proc : TGetChildProc; Root : TComponent); override;
function ChildClassAllowed(ChildClass: TClass): boolean; override;
procedure PaintControls(DC: HDC; First: TControl);
procedure PaintHandler(var TheMessage: TLMPaint);
procedure PaintWindow(DC: HDC); virtual;
@ -2361,6 +2366,9 @@ end.
{ =============================================================================
$Log$
Revision 1.178 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.177 2004/02/21 15:37:33 mattias
moved compiler options to project menu, added -CX for smartlinking

7
lcl/extctrls.pp
View File

@ -135,7 +135,6 @@ type
fPageIndex: Integer;
fPageIndexOnLastChange: integer;
fPageList: TList; // List of TCustomPage
//fMultiLine: boolean;
fOnPageChanged: TNotifyEvent;
fShowTabs: Boolean;
fTabPosition: TTabPosition;
@ -150,12 +149,10 @@ type
function GetPageCount : integer;
function GetPageIndex: Integer;
function IsStoredActivePage: boolean;
//function InternalSetMultiLine(Value: boolean): boolean;
procedure SetActivePage(const Value: String);
procedure SetActivePageComponent(const AValue: TCustomPage);
procedure SetImages(const AValue: TImageList);
procedure SetOptions(const AValue: TNoteBookOptions);
//procedure SetMultiLine(Value: boolean);
procedure SetPageIndex(AValue: Integer);
procedure SetPages(AValue: TStrings);
procedure SetShowTabs(AValue: Boolean);
@ -171,6 +168,7 @@ type
procedure ReadState(Reader: TAbstractReader); override;
procedure ShowControl(APage: TControl); override;
procedure UpdateTabProperties; virtual;
function ChildClassAllowed(ChildClass: TClass): boolean; override;
property ActivePageComponent: TCustomPage read GetActivePageComponent
write SetActivePageComponent;
property ActivePage: String read GetActivePage write SetActivePage
@ -925,6 +923,9 @@ end.
{
$Log$
Revision 1.98 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.97 2004/02/21 01:01:03 mattias
added uninstall popupmenuitem to package graph explorer

8
lcl/imglist.pp
View File

@ -50,8 +50,8 @@ interface
{$endif}
uses
SysUtils, Classes, FPCAdds, LCLStrConsts, vclGlobals, LCLProc, Graphics,
GraphType;
SysUtils, Classes, FPCAdds, LCLStrConsts, LResources, vclGlobals, LCLProc,
Graphics, GraphType;
type
TImageIndex = type integer;
@ -154,6 +154,7 @@ type
function AddIcon(Image: TIcon): Integer;
procedure AddImages(Value: TCustomImageList);
function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
function AddFromLazarusResource(const ResourceName: string): integer;
procedure Change;
procedure Clear;
constructor CreateSize(AWidth, AHeight: Integer);
@ -210,6 +211,9 @@ end.
{
$Log$
Revision 1.15 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.14 2004/02/02 19:13:31 mattias
started reading TImageList in Delphi format

10
lcl/include/buttons.inc
View File

@ -163,9 +163,19 @@ begin
CNSendMessage(LM_SETSHORTCUT, Self, @FShortcut);
end;
end;
function TButton.ChildClassAllowed(ChildClass: TClass): boolean;
begin
// no childs
Result:=false;
end;
{ =============================================================================
$Log$
Revision 1.17 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.16 2004/01/21 10:19:16 micha
enable tabstops for controls; implement tabstops in win32 intf

60
lcl/include/control.inc
View File

@ -685,6 +685,11 @@ begin
Result:=0;
end;
function TControl.ChildClassAllowed(ChildClass: TClass): boolean;
begin
Result:=false;
end;
{------------------------------------------------------------------------------
procedure TControl.DoOnResize;
@ -1643,6 +1648,40 @@ begin
CNSendMessage(LM_AddChild, Self, nil);
end;
{------------------------------------------------------------------------------
function TControl.CheckChildClassAllowed(ChildClass: TClass;
ExceptionOnInvalid: boolean): boolean;
Checks if this control can be the parent of a control of class ChildClass.
------------------------------------------------------------------------------}
function TControl.CheckChildClassAllowed(ChildClass: TClass;
ExceptionOnInvalid: boolean): boolean;
procedure RaiseInvalidChild;
begin
raise Exception.Create(ClassName+' can not have '+ChildClass.ClassName+' as child');
end;
begin
Result:=ChildClassAllowed(ChildClass);
if (not Result) and ExceptionOnInvalid then
RaiseInvalidChild;
end;
{------------------------------------------------------------------------------
procedure TControl.CheckNewParent(AParent: TWinControl);
Checks if this control can be the child of AParent.
This check is executed in SetParent.
------------------------------------------------------------------------------}
procedure TControl.CheckNewParent(AParent: TWinControl);
begin
if (AParent<>nil) then AParent.CheckChildClassAllowed(ClassType,true);
if AParent = Self then begin
raise EInvalidOperation.Create('A control can not have itself as parent');
end;
end;
{------------------------------------------------------------------------------
TControl SetAutoSize
------------------------------------------------------------------------------}
@ -2218,20 +2257,10 @@ end;
------------------------------------------------------------------------------}
Procedure TControl.SetParent(AParent : TWinControl);
begin
{ if AParent = nil
then Assert(False, Format('Trace:[TControl.SetParent] %s --> Parent: nil', [ClassName]))
else Assert(False, Format('Trace:[TControl.SetParent] %s --> Parent: %s', [ClassName, AParent.ClassName]));
}
if FParent <> AParent
then begin
if AParent = Self
then begin
Assert(False, 'Trace:[TControl.SetParent] EInvalidOperation --> FParent = Self');
raise EInvalidOperation.Create('A control can''t have itself as parent');
end;
if FParent <> nil then FParent.RemoveControl(Self);
if AParent <> nil then AParent.InsertControl(Self);
end;
if FParent = AParent then exit;
CheckNewParent(AParent);
if FParent <> nil then FParent.RemoveControl(Self);
if AParent <> nil then AParent.InsertControl(Self);
end;
procedure TControl.SetParentColor(Value : Boolean);
@ -2769,6 +2798,9 @@ end;
{ =============================================================================
$Log$
Revision 1.171 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.170 2004/02/21 15:37:33 mattias
moved compiler options to project menu, added -CX for smartlinking

12
lcl/include/customedit.inc
View File

@ -308,6 +308,15 @@ begin
inherited SetText(Value);
end;
{------------------------------------------------------------------------------
function TCustomEdit.ChildClassAllowed(ChildClass: TClass): boolean;
------------------------------------------------------------------------------}
function TCustomEdit.ChildClassAllowed(ChildClass: TClass): boolean;
begin
// no childs
Result:=false;
end;
{------------------------------------------------------------------------------
Method: TCustomEdit.SetModified
Params: Value to set FModified to
@ -357,6 +366,9 @@ end;
{ =============================================================================
$Log$
Revision 1.23 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.22 2004/02/04 00:04:37 mattias
added some TEdit ideas to TSpinEdit

1
lcl/include/customlabelededit.inc
View File

@ -116,6 +116,5 @@ begin
FEditLabel.FocusControl := Self;
end;
// included by extctrls.pp

10
lcl/include/customnotebook.inc
View File

@ -315,7 +315,7 @@ begin
if PageClass=nil then
RaiseGDBException('');
inherited Create(TheOwner);
{create the control}
fCompStyle := csNoteBook;
fPageList := TList.Create;
@ -655,6 +655,11 @@ begin
CNSendMessage(LM_NB_UpdateTab, Page[i], nil);
end;
function TCustomNotebook.ChildClassAllowed(ChildClass: TClass): boolean;
begin
Result:=(ChildClass<>nil) and (ChildClass=PageClass);
end;
{------------------------------------------------------------------------------
TCustomNotebook Change
------------------------------------------------------------------------------}
@ -787,6 +792,9 @@ end;}
{ =============================================================================
$Log$
Revision 1.42 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.41 2004/01/21 10:19:16 micha
enable tabstops for controls; implement tabstops in win32 intf

1
lcl/include/custompage.inc
View File

@ -89,6 +89,7 @@ var
i: integer;
begin
if AParent=Parent then exit;
CheckNewParent(AParent);
OldParent:=Parent;
if (OldParent<>AParent) and (OldParent<>nil)

19
lcl/include/imglist.inc
View File

@ -165,6 +165,22 @@ begin
end;
end;
{------------------------------------------------------------------------------
function TCustomImageList.AddFromLazarusResource(const ResourceName: string
): integer;
Load TBitmap from lazarus resources and add it.
------------------------------------------------------------------------------}
function TCustomImageList.AddFromLazarusResource(const ResourceName: string
): integer;
var
ABitmap: TBitmap;
begin
ABitmap:=TBitmap.Create;
ABitmap.LoadFromLazarusResource(ResourceName);
Result:=AddDirect(ABitmap,nil);
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.AllocBitmap
Params: Amount: the amount of free image position which should be availabe
@ -1066,6 +1082,9 @@ end;
{
$Log$
Revision 1.23 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.22 2004/02/02 21:31:08 mattias
reduced output

20
lcl/include/toolbar.inc
View File

@ -34,6 +34,7 @@ begin
csDoubleClicks, csMenuEvents, csSetCaption];
FButtonWidth := 23;
FButtonHeight := 22;
FButtonStyle := tbbsIcon;
FDropDownWidth := 10;
FNewStyle := True;
FWrapable := True;
@ -142,7 +143,7 @@ begin
UpdateVisibleBar;
exit;
end;
writeln('TToolBar.ControlsAligned START');
//writeln('TToolBar.ControlsAligned START');
// ToDo
// hack: stupid put in a row
for i:=0 to ControlCount-1 do begin
@ -151,9 +152,9 @@ begin
NewTop:=0;
NewWidth:=ButtonWidth;
NewHeight:=ButtonHeight;
writeln('TToolBar.ControlsAligned ',CurControl.Name,
' Old=',CurControl.Left,',',CurControl.Top,',',CurControl.Width,',',CurControl.Height,
' New=',NewLeft,',',NewTop,',',NewWidth,',',NewHeight);
//writeln('TToolBar.ControlsAligned ',CurControl.Name,
// ' Old=',CurControl.Left,',',CurControl.Top,',',CurControl.Width,',',CurControl.Height,
// ' New=',NewLeft,',',NewTop,',',NewWidth,',',NewHeight);
CurControl.SetBoundsKeepBase(NewLeft,NewTop,NewWidth,NewHeight,true);
end;
end;
@ -186,6 +187,13 @@ begin
end;
end;
procedure TToolBar.SetButtonStyle(const AValue: TToolBarButtonStyle);
begin
if FButtonStyle=AValue then exit;
FButtonStyle:=AValue;
UpdateVisibleBar;
end;
procedure TToolBar.SetButtonWidth(const AValue: Integer);
var
i: Integer;
@ -322,7 +330,6 @@ begin
Include(FToolBarFlags,tbfUpdateVisibleBarNeeded);
exit;
end;
writeln('TToolBar.UpdateVisibleBar');
ReAlign;
Invalidate;
Exclude(FToolBarFlags,tbfUpdateVisibleBarNeeded);
@ -1931,6 +1938,9 @@ end;
{ =============================================================================
$Log$
Revision 1.20 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.19 2004/02/21 15:37:33 mattias
moved compiler options to project menu, added -CX for smartlinking

190
lcl/include/toolbutton.inc
View File

@ -55,6 +55,7 @@ begin
fCompStyle := csToolButton;
FImageIndex := -1;
FStyle := tbsButton;
FState:=tbsEnabled;
ControlStyle := [csCaptureMouse, csSetCaption];
SetInitialBounds(0,0,23,22);
end;
@ -62,28 +63,33 @@ end;
procedure TToolButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
SetMouseInControl(true);
if (Style=tbsDropDown) and (Button=mbLeft) and Enabled then
// switch
Down := not Down;
if (Style=tbsCheck) and (Button=mbLeft) and Enabled then begin
;
end;
inherited MouseDown(Button,Shift,X,Y);
end;
procedure TToolButton.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
SetMouseInControl((X>=0) and (X<ClientWidth) and (Y>=0) and (Y<ClientHeight));
inherited MouseMove(Shift, X, Y);
if (Style=tbsDropDown) and MouseCapture then
// while dragging: down when mouse in, and up, when mouse out of control
Down := (X>=0) and (X<ClientWidth) and (Y>=0) and (Y<ClientHeight);
Down := FMouseInControl;
end;
procedure TToolButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
SetMouseInControl(true);
inherited MouseUp(Button, Shift, X, Y);
if (Button=mbLeft) and (X>=0) and (X<ClientWidth) and (Y>=0) and
(Y<ClientHeight)
then begin
if (Button=mbLeft) and FMouseInControl then begin
if Style=tbsDropDown then Down:=False;
if Style=tbsCheck then Down:=false;
Click;
end;
end;
@ -101,18 +107,40 @@ begin
end;
procedure TToolButton.Paint;
procedure DrawDropDownArrow(const DropDownButtonRect: TRect);
var
ArrowRect: TRect;
Points: array[1..3] of TPoint;
begin
ArrowRect:=DropDownButtonRect;
ArrowRect.Left:=DropDownButtonRect.Left+2;
ArrowRect.Right:=Max(DropDownButtonRect.Right-2,ArrowRect.Left);
ArrowRect.Top:=(DropDownButtonRect.Top+DropDownButtonRect.Bottom
+ArrowRect.Left-ArrowRect.Right) div 2;
ArrowRect.Bottom:=ArrowRect.Top-ArrowRect.Left+ArrowRect.Right;
Points[1]:=Point(ArrowRect.Left,ArrowRect.Top);
Points[2]:=Point((ArrowRect.Left+ArrowRect.Right) div 2,ArrowRect.Bottom);
Points[3]:=Point(ArrowRect.Right,ArrowRect.Top);
Canvas.Brush.Color:=clBlack;
Canvas.Pen.Color:=clBlack;
Canvas.Polygon(@Points[1],3);
end;
var
PaintRect: TRect;
ButtonRect: TRect;
DropDownButtonRect: TRect;
DividerRect: TRect;
IconWidth: Integer;
IconHeight: Integer;
IconLeft: Integer;
IconTop: Integer;
TextSize: TSize;
TextPos: TPoint;
IconSize: TPoint;
IconPos: TPoint;
ImgList: TCustomImageList;
ImgIndex: integer;
begin
writeln('TToolButton.Paint A FToolBar=',HexStr(Cardinal(FToolBar),8),' ',ClientWidth,',',ClientHeight);
if FToolBar<>nil then begin
writeln('TToolButton.Paint A ',Name,' FToolBar=',HexStr(Cardinal(FToolBar),8),' ',ClientWidth,',',ClientHeight,' ',ord(Style));
if (FToolBar<>nil) and (ClientWidth>0) and (ClientHeight>0) then begin
PaintRect:=ClientRect; // the whole paint area
// calculate button area(s)
@ -123,29 +151,81 @@ begin
ButtonRect.Right:=DropDownButtonRect.Left;
end;
// calculate text size
TextSize.cx:=0;
TextSize.cy:=0;
if Style in [tbsButton,tbsDropDown,tbsCheck] then begin
if (Caption<>'')
and (FToolBar.ButtonStyle
in [tbbsText,tbbsIconAboveText,tbbsIconLeftOfText])
then begin
TextSize:=Canvas.TextExtent(Caption);
end;
end;
// calculate icon size
IconSize:=Point(0,0);
GetCurrentIcon(ImgList,ImgIndex);
if (ImgList<>nil) then
IconSize:=Point(ImgList.Width,ImgList.Height);
// calculate text and icon position
TextPos:=Point(0,0);
IconPos:=Point(0,0);
case FToolBar.ButtonStyle of
tbbsText:
begin
TextPos.X:=(ButtonRect.Left+ButtonRect.Right-TextSize.cx) div 2;
TextPos.Y:=(ButtonRect.Top+ButtonRect.Bottom-TextSize.cy) div 2;
end;
tbbsIcon:
begin
IconPos.X:=(ButtonRect.Left+ButtonRect.Right-IconSize.x) div 2;
IconPos.Y:=(ButtonRect.Top+ButtonRect.Bottom-IconSize.y) div 2;
end;
tbbsIconLeftOfText:
begin
IconPos.X:=(ButtonRect.Left+ButtonRect.Right-IconSize.x-TextSize.cy-2) div 2;
IconPos.Y:=(ButtonRect.Top+ButtonRect.Bottom-IconSize.y) div 2;
TextPos.X:=IconPos.X+2;
TextPos.Y:=(ButtonRect.Top+ButtonRect.Bottom-TextSize.cy) div 2;
end;
tbbsIconAboveText:
begin
IconPos.X:=(ButtonRect.Left+ButtonRect.Right-IconSize.x) div 2;
IconPos.Y:=(ButtonRect.Top+ButtonRect.Bottom-IconSize.y-TextSize.cy-2) div 2;
TextPos.X:=(ButtonRect.Left+ButtonRect.Right-TextSize.cx) div 2;
TextPos.Y:=IconPos.Y+IconSize.Y+2;
end;
end;
// draw button
FLastButtonDrawFlags:=GetButtonDrawFlags;
if Style in [tbsButton,tbsDropDown,tbsCheck] then begin
DrawFrameControl(Canvas.GetUpdatedHandle([csBrushValid,csPenValid]),
ButtonRect, DFC_BUTTON, FLastButtonDrawFlags);
PaintRect{ButtonRect}, DFC_BUTTON, FLastButtonDrawFlags);
end;
// draw dropdown button
if Style in [tbsDropDown] then begin
DrawFrameControl(Canvas.GetUpdatedHandle([csBrushValid,csPenValid]),
DropDownButtonRect, DFC_BUTTON, FLastButtonDrawFlags);
//DrawFrameControl(Canvas.GetUpdatedHandle([csBrushValid,csPenValid]),
// DropDownButtonRect, DFC_BUTTON, FLastButtonDrawFlags);
DrawDropDownArrow(DropDownButtonRect);
end;
// draw icon
if (Style in [tbsButton,tbsDropDown,tbsCheck])
and (ImageIndex>=0) and (FToolBar.Images<>nil)
and (FToolBar.Images.Count>ImageIndex) then begin
IconWidth:=FToolBar.Images.Width;
IconHeight:=FToolBar.Images.Height;
IconLeft:=(ButtonRect.Left+ButtonRect.Right-IconWidth) div 2;
IconTop:=(ButtonRect.Top+ButtonRect.Bottom-IconHeight) div 2;
FToolBar.Images.Draw(Canvas,IconLeft,IconTop,ImageIndex,
Enabled and not Indeterminate);
if (ImgList<>nil) then begin
ImgList.Draw(Canvas,IconPos.X,IconPos.Y,ImgIndex,true);
end;
// draw text
if (TextSize.cx>0) then begin
Canvas.TextOut(TextPos.X,TextPos.Y,Caption);
end;
// draw separator (at runtime: just space, at designtime: a rectangle)
@ -157,9 +237,9 @@ begin
end;
// draw divider
if (Style in [tbsSeparator,tbsDivider]) then begin
DividerRect.Left:=(ButtonRect.Left+ButtonRect.Right) div 2;
DividerRect.Right:=DividerRect.Left+2;
if (Style in [tbsDivider]) then begin
DividerRect.Left:=((ButtonRect.Left+ButtonRect.Right) div 2)-2;
DividerRect.Right:=DividerRect.Left+4;
DividerRect.Top:=2;
DividerRect.Bottom:=Max(DividerRect.Top,PaintRect.Bottom-2);
DrawEdge(Canvas.Handle,DividerRect,EDGE_ETCHED,BF_LEFT);
@ -209,13 +289,23 @@ begin
Message.Result := 0;
end;
procedure TToolButton.CMMouseEnter(var Message: TLMessage);
begin
SetMouseInControl(true);
end;
procedure TToolButton.CMMouseLeave(var Message: TLMessage);
begin
SetMouseInControl(false);
end;
procedure TToolButton.SetDown(Value: Boolean);
begin
if Value = FDown then exit;
FDown := Value;
if FToolBar <> nil then begin
Invalidate;
if FToolBar <> nil then
FToolBar.ToolButtonDown(Self,FDown);
end;
end;
procedure TToolButton.SetDropdownMenu(Value: TPopupMenu);
@ -293,6 +383,13 @@ begin
RefreshControl;
end;
procedure TToolButton.SetMouseInControl(NewMouseInControl: Boolean);
begin
if FMouseInControl=NewMouseInControl then exit;
FMouseInControl:=NewMouseInControl;
Invalidate;
end;
procedure TToolButton.BeginUpdate;
begin
Inc(FUpdateCount);
@ -334,6 +431,36 @@ begin
and (FToolBar <> nil) and FToolBar.CheckMenuDropdown(Self);
end;
procedure TToolButton.GetCurrentIcon(var ImageList: TCustomImageList;
var Index: integer);
begin
ImageList:=nil;
Index:=-1;
if (ImageIndex<0) or (FToolBar=nil) then exit;
if Style in [tbsButton,tbsDropDown,tbsCheck] then begin
if (FToolBar.ButtonStyle in [tbbsText,tbbsIconAboveText,tbbsIconLeftOfText])
then begin
Index:=ImageIndex;
if Enabled and FMouseInControl then
// if mouse over button then use HotImages
ImageList:=FToolBar.HotImages
else if not Enabled then
// if button disabled then use HotImages
ImageList:=FToolBar.DisabledImages;
if (ImageList=nil) or (ImageList.Count<=ImageIndex) then begin
// if no special icon available, then try the default Images
ImageList:=FToolBar.Images;
if (ImageList=nil) or (ImageList.Count<=ImageIndex) then begin
// no icon available
ImageList:=nil;
Index:=-1;
end;
end;
end;
end;
end;
function TToolButton.IsCheckedStored: Boolean;
begin
Result := (ActionLink = nil)
@ -360,7 +487,8 @@ begin
Result:=DFCS_BUTTONPUSH;
if FDown then inc(Result,DFCS_PUSHED);
if not Enabled then inc(Result,DFCS_INACTIVE);
if Down and (not (csDesigning in ComponentState)) then
if (not (csDesigning in ComponentState)) and (not FMouseInControl)
and (not FDown) then
inc(Result,DFCS_FLAT);
end;
@ -368,6 +496,7 @@ procedure TToolButton.SetParent(AParent: TWinControl);
var
i: Integer;
begin
CheckNewParent(AParent);
if AParent=Parent then exit;
// remove from old button list
@ -864,6 +993,9 @@ end;
{
$Log$
Revision 1.10 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.9 2004/02/21 15:37:33 mattias
moved compiler options to project menu, added -CX for smartlinking

13
lcl/include/wincontrol.inc
View File

@ -834,6 +834,16 @@ Begin
end;
End;
{-------------------------------------------------------------------------------
function TWinControl.ChildClassAllowed(ChildClass: TClass): boolean;
Allow TControl as child.
-------------------------------------------------------------------------------}
function TWinControl.ChildClassAllowed(ChildClass: TClass): boolean;
begin
Result:=(ChildClass<>nil) and ChildClass.InheritsFrom(TControl);
end;
{-------------------------------------------------------------------------------
TWinControl GetClientOrigin
Result: TPoint
@ -3378,6 +3388,9 @@ end;
{ =============================================================================
$Log$
Revision 1.203 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.202 2004/02/21 15:37:33 mattias
moved compiler options to project menu, added -CX for smartlinking

5
lcl/interfaces/gtk/gtkobject.inc
View File

@ -6720,7 +6720,7 @@ begin
csToolButton:
begin
{$IFDEF NewToolBar}
p := gtk_button_new_with_label(StrTemp);
p := gtk_fixed_new();
{$ELSE}
AccelText := Ampersands2Underscore(StrTemp);
//p := gtk_button_new_with_label(StrTemp);
@ -9225,6 +9225,9 @@ end;
{ =============================================================================
$Log$
Revision 1.471 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.470 2004/02/21 15:37:33 mattias
moved compiler options to project menu, added -CX for smartlinking

10
lcl/pairsplitter.pas
View File

@ -104,6 +104,7 @@ type
procedure CreateSides;
procedure Loaded; override;
class function IsSupportedByInterface: boolean;
function ChildClassAllowed(ChildClass: TClass): boolean; override;
public
property Sides[Index: integer]: TPairSplitterSide read GetSides;
property SplitterType: TPairSplitterType read FSplitterType
@ -156,9 +157,7 @@ procedure TPairSplitterSide.SetParent(AParent: TWinControl);
var
ASplitter: TCustomPairSplitter;
begin
if (AParent<>nil) and (not (AParent is TCustomPairSplitter)) then
RaiseGDBException(
'TPairSplitterSide.SetParent Parent not TCustomPairSplitter');
CheckNewParent(AParent);
// remove from side list of old parent
ASplitter:=Splitter;
if ASplitter<>nil then begin
@ -360,5 +359,10 @@ begin
Result:=PairSplitterGetInterfaceInfo;
end;
function TCustomPairSplitter.ChildClassAllowed(ChildClass: TClass): boolean;
begin
Result:=ChildClass.InheritsFrom(TPairSplitterSide);
end;
end.

4
lcl/stdctrls.pp
View File

@ -492,6 +492,7 @@ type
procedure SetSelStart(Val : integer); virtual;
procedure SetSelText(const Val : string); virtual;
procedure SetText(const Value: TCaption); override;
function ChildClassAllowed(ChildClass: TClass): boolean; override;
public
constructor Create(AOwner: TComponent); override;
procedure SelectAll;
@ -1495,6 +1496,9 @@ end.
{ =============================================================================
$Log$
Revision 1.132 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.131 2004/02/13 18:21:31 mattias
fixed combo chane