paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-16 13:29:37 +02:00
Code Issues Packages Projects Releases Wiki Activity

started advanced LCL auto sizing

Browse Source 
git-svn-id: trunk@5198 -
This commit is contained in:
mattias 2004-02-13 15:49:54 +00:00
parent 7bebd2455f
commit ce51572453
13 changed files with 750 additions and 209 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
lcl/comctrls.pp
View File

@ -840,7 +840,6 @@ type
public
constructor Create(TheOwner: TComponent); override;
function CheckMenuDropdown: Boolean; dynamic;
procedure ChangeBounds(NewLeft, NewTop, NewWidth, NewHeight: Integer); override;
property Index: Integer read GetIndex;
published
property Action;
@ -2235,6 +2234,9 @@ end.
{ =============================================================================
$Log$
Revision 1.109 2004/02/13 15:49:54 mattias
started advanced LCL auto sizing
Revision 1.108 2004/02/12 18:09:10 mattias
removed win32 specific TToolBar code in new TToolBar, implemented TWinControl.FlipChildren

481
lcl/controls.pp
View File

@ -26,6 +26,7 @@ unit Controls;
{$mode objfpc}{$H+}
{off $DEFINE BUFFERED_WMPAINT}
interface
{$ifdef Trace}
@ -493,6 +494,10 @@ type
TConstraintSize = 0..MaxInt;
TSizeConstraintsOption = (scoAdviceWidthAsMin, scoAdviceWidthAsMax,
scoAdviceHeightAsMin, scoAdviceHeightAsMax);
TSizeConstraintsOptions = set of TSizeConstraintsOption;
TSizeConstraints = class(TPersistent)
private
FControl: TControl;
@ -505,6 +510,8 @@ type
FMinInterfaceWidth: integer;
FMinWidth: TConstraintSize;
FOnChange: TNotifyEvent;
FOptions: TSizeConstraintsOptions;
procedure SetOptions(const AValue: TSizeConstraintsOptions);
protected
procedure Change; dynamic;
procedure AssignTo(Dest: TPersistent); override;
@ -527,6 +534,7 @@ type
property MinInterfaceHeight: integer read FMinInterfaceHeight;
property MinInterfaceWidth: integer read FMinInterfaceWidth;
property Control: TControl read FControl;
property Options: TSizeConstraintsOptions read FOptions write SetOptions default [];
published
property MaxHeight: TConstraintSize read FMaxHeight write SetMaxHeight default 0;
property MaxWidth: TConstraintSize read FMaxWidth write SetMaxWidth default 0;
@ -538,7 +546,58 @@ type
var MinWidth, MinHeight, MaxWidth, MaxHeight : TConstraintSize) of object;
TTabOrder = -1..32767;
{ TControlBorderSpacing }
{ TControlBorderSpacing defines the spacing around a control, around its
childs and between its childs.
Left, Top, Right, Bottom: integer;
minimum space left to the control.
For example: Control A lies left of control B.
A has borderspacing Right=10 and B has borderspacing Left=5.
Then A and B will have a minimum space of 10 between.
Around: integer;
same as Left, Top, Right and Bottom all at once. This will be added to
the effective Left, Top, Right and Bottom.
Example: Left=3 and Around=5 results in a minimum spacing to the left
of 8.
}
TSpacingSize = 0..MaxInt;
TControlBorderSpacing = class(TPersistent)
private
FAround: TSpacingSize;
FBottom: TSpacingSize;
FControl: TControl;
FLeft: TSpacingSize;
FOnChange: TNotifyEvent;
FRight: TSpacingSize;
FTop: TSpacingSize;
procedure SetAround(const AValue: TSpacingSize);
procedure SetBottom(const AValue: TSpacingSize);
procedure SetLeft(const AValue: TSpacingSize);
procedure SetRight(const AValue: TSpacingSize);
procedure SetTop(const AValue: TSpacingSize);
protected
procedure Change; dynamic;
public
constructor Create(OwnerControl: TControl);
procedure Assign(Source: TPersistent); override;
procedure AssignTo(Dest: TPersistent); override;
function IsEqual(Spacing: TControlBorderSpacing): boolean;
public
property Control: TControl read FControl;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
published
property Left: TSpacingSize read FLeft write SetLeft;
property Top: TSpacingSize read FTop write SetTop;
property Right: TSpacingSize read FRight write SetRight;
property Bottom: TSpacingSize read FBottom write SetBottom;
property Around: TSpacingSize read FAround write SetAround;
end;
{ TControlActionLink }
@ -569,6 +628,8 @@ type
{ TControl }
TTabOrder = -1..32767;
TControlShowHintEvent = procedure(Sender: TObject; HintInfo: Pointer) of object;
TContextPopupEvent = procedure(Sender: TObject; MousePos: TPoint; var Handled: Boolean) of object;
@ -595,6 +656,7 @@ type
FBaseBounds: TRect;
FBaseBoundsLock: integer;
FBaseParentClientSize: TPoint;
FBorderSpacing: TControlBorderSpacing;
FCaption : TCaption;
FColor : TColor;
FConstraints : TSizeConstraints;
@ -693,6 +755,7 @@ type
procedure DoDragMsg(var Dragmsg : TCMDrag);
procedure DoMouseDown(var Message: TLMMouse; Button: TMouseButton; Shift:TShiftState);
procedure DoMouseUp(var Message: TLMMouse; Button: TMouseButton);
procedure SetBorderSpacing(const AValue: TControlBorderSpacing);
procedure SetBoundsRect(const ARect : TRect);
procedure SetClientHeight(Value: Integer);
procedure SetClientSize(Value: TPoint);
@ -718,17 +781,36 @@ type
procedure SetWidth(Value: Integer);
Procedure UpdateTabOrder(value : TTabOrder);
protected
AutoSizing : Boolean;
FControlState: TControlState;
protected
// sizing/aligning
AutoSizing: Boolean;
procedure AdjustSize; dynamic;
procedure DoAutoSize; Virtual;
procedure SetAlign(Value: TAlign); virtual;
procedure SetAnchors(const AValue: TAnchors); virtual;
procedure SetAutoSize(const Value : Boolean); virtual;
procedure BoundsChanged; dynamic;
procedure DoConstraintsChange(Sender : TObject); virtual;
procedure DoConstraintsChange(Sender: TObject); virtual;
procedure DoBorderSpacingChange(Sender: TObject); virtual;
procedure SendMoveSizeMessages(SizeChanged, PosChanged: boolean); virtual;
procedure Changed;
procedure ConstrainedResize(var MinWidth, MinHeight, MaxWidth, MaxHeight : TConstraintSize); virtual;
procedure DoOnResize; virtual;
procedure DoOnChangeBounds; virtual;
procedure Resize; virtual;
procedure RequestAlign; dynamic;
procedure UpdateBaseBounds(StoreBounds, StoreParentClientSize,
UseLoadedValues: boolean); virtual;
procedure LockBaseBounds;
procedure UnlockBaseBounds;
procedure UpdateAnchorRules;
procedure ChangeBounds(ALeft, ATop, AWidth, AHeight : integer); virtual;
procedure DoSetBounds(ALeft, ATop, AWidth, AHeight : integer); virtual;
procedure ChangeScale(M,D : Integer); dynamic;
Function CanAutoSize(var NewWidth, NewHeight : Integer): Boolean; virtual;
procedure SetAlignedBounds(aLeft, aTop, aWidth, aHeight: integer); virtual;
protected
// protected messages
procedure WMLButtonDown(Var Message: TLMLButtonDown); message LM_LBUTTONDOWN;
procedure WMRButtonDown(Var Message: TLMRButtonDown); message LM_RBUTTONDOWN;
procedure WMMButtonDown(Var Message: TLMMButtonDown); message LM_MBUTTONDOWN;
@ -758,22 +840,10 @@ type
procedure CMParentColorChanged(var Message : TLMessage); message CM_PARENTCOLORCHANGED;
procedure CMParentShowHintChanged(var Message : TLMessage); message CM_PARENTSHOWHINTCHANGED;
procedure CMVisibleChanged(var Message : TLMessage); message CM_VISIBLECHANGED;
procedure ConstrainedResize(var MinWidth, MinHeight, MaxWidth, MaxHeight : TConstraintSize); virtual;
procedure Changed;
function GetPalette: HPalette; virtual;
procedure DoOnResize; virtual;
procedure DoOnChangeBounds; virtual;
procedure Resize; virtual;
procedure Loaded; override;
procedure AssignTo(Dest: TPersistent); override;
procedure RequestAlign; dynamic;
procedure UpdateBaseBounds(StoreBounds, StoreParentClientSize,
UseLoadedValues: boolean); virtual;
procedure LockBaseBounds;
procedure UnlockBaseBounds;
procedure UpdateAnchorRules;
procedure ChangeBounds(ALeft, ATop, AWidth, AHeight : integer); virtual;
procedure DoSetBounds(ALeft, ATop, AWidth, AHeight : integer); virtual;
procedure ChangeScale(M,D : Integer); dynamic;
procedure BeginAutoDrag; dynamic;
procedure DoEndDock(Target: TObject; X, Y: Integer); dynamic;
procedure DoDock(NewDockSite: TWinControl; var ARect: TRect); dynamic;
@ -809,7 +879,6 @@ type
procedure MouseMove(Shift: TShiftState; X,Y: Integer); Dynamic;
procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); dynamic;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
Function CanAutoSize(var NewWidth, NewHeight : Integer): Boolean; virtual;
Function CanTab: Boolean; virtual;
Function Focused : Boolean; dynamic;
Procedure SetFocus; virtual;
@ -822,7 +891,6 @@ type
Function GetEnabled: Boolean; virtual;
Function GetPopupMenu: TPopupMenu; dynamic;
procedure DoOnShowHint(HintInfo: Pointer);
procedure SetAlignedBounds(aLeft, aTop, aWidth, aHeight: integer); virtual;
procedure VisibleChanging; dynamic;
procedure AddControlHandler(HandlerType: TControlHandlerType;
AMethod: TMethod; AsLast: boolean);
@ -831,12 +899,13 @@ type
procedure DoContextPopup(const MousePos: TPoint; var Handled: Boolean); virtual;
procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); dynamic;
protected
// optional properties (not every descendent supports them)
property ActionLink: TControlActionLink read FActionLink write FActionLink;
property AutoSize: Boolean read FAutoSize write SetAutoSize default FALSE;
property Ctl3D: Boolean read FCtl3D write FCtl3D;//Is this needed for anything other than compatability?
property DragCursor: TCursor read FDragCursor write SetDragCursor default crDrag;
property DragKind: TDragKind read FDragKind write FDragKind default dkDrag;
property DragMode: TDragMode read fDragMode write SetDragMode default dmManual;
property IsControl: Boolean read FIsControl write FIsControl;
property MouseCapture: Boolean read GetMouseCapture write SetMouseCapture;
property ParentFont: Boolean read FParentFont write FParentFont;
property ParentColor: Boolean read FParentColor write SetParentColor;
@ -895,8 +964,8 @@ type
Function Dragging : Boolean;
procedure Show;
procedure Update; virtual;
procedure SetZOrderPosition(Position : Integer); virtual;
Procedure SetZOrder(Topmost: Boolean); virtual;
procedure SetZOrderPosition(NewPosition: Integer); virtual;
Procedure SetZOrder(TopMost: Boolean); virtual;
function HandleObjectShouldBeVisible: boolean; virtual;
procedure InitiateAction; virtual;
public
@ -908,9 +977,11 @@ type
AsLast: boolean);
procedure RemoveHandlerOnChangeBounds(OnChangeBoundsEvent: TNotifyEvent);
public
// standard properties, which should be supported by all descendents
property Anchors: TAnchors read FAnchors write SetAnchors default [akLeft,akTop];
property Action: TBasicAction read GetAction write SetAction;
property Align: TAlign read FAlign write SetAlign;
property BorderSpacing: TControlBorderSpacing read FBorderSpacing write SetBorderSpacing;
property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
property Caption: TCaption read GetText write SetText stored IsCaptionStored;
property ClientOrigin: TPoint read GetClientOrigin;
@ -921,9 +992,13 @@ type
property ControlState: TControlState read FControlState write FControlState;
property ControlStyle: TControlStyle read FControlStyle write FControlStyle;
property Color: TColor read FColor write SetColor stored ColorIsStored default clWindow;
property Ctl3D: Boolean read FCtl3D write FCtl3D;//Is this needed for anything other than compatability?
property Enabled: Boolean read GetEnabled write SetEnabled stored IsEnabledStored default True;
property Font: TFont read FFont write SetFont stored IsFontStored;
property IsControl: Boolean read FIsControl write FIsControl;
property OnResize: TNotifyEvent read FOnResize write FOnResize;
property OnChangeBounds: TNotifyEvent read FOnChangeBounds write FOnChangeBounds;
property OnClick: TNotifyEvent read FOnClick write FOnClick stored IsOnClickStored;
property OnShowHint: TControlShowHintEvent read FOnShowHint write FOnShowHint;
property Parent: TWinControl read FParent write SetParent;
property PopupMenu: TPopupmenu read GetPopupmenu write SetPopupMenu;
property ShowHint: Boolean read FShowHint write SetShowHint stored IsShowHintStored default False;
@ -941,11 +1016,6 @@ type
property TBDockHeight: Integer read GetTBDockHeight write FTBDockHeight;
property UndockHeight: Integer read GetUndockHeight write FUndockHeight;
property UndockWidth: Integer read GetUndockWidth write FUndockWidth;
public
property OnResize: TNotifyEvent read FOnResize write FOnResize;
property OnChangeBounds: TNotifyEvent read FOnChangeBounds write FOnChangeBounds;
property OnClick: TNotifyEvent read FOnClick write FOnClick stored IsOnClickStored;
property OnShowHint: TControlShowHintEvent read FOnShowHint write FOnShowHint;
published
property Cursor: TCursor read FCursor write SetCursor default crDefault;
property Left: Integer read FLeft write SetLeft;
@ -975,6 +1045,140 @@ type
TGetChildProc = procedure(Child: TComponent) of Object;
{ TControlChildSizing }
{ LeftRightSpacing, TopBottomSpacing: integer;
minimum space between left client border and left most childs.
For example: ClientLeftRight=5 means childs Left position is at least 5.
HorizontalSpacing, VerticalSpacing: integer;
minimum space between each child horizontally
}
{ Defines how child controls are resized/aligned.
cesAnchorAligning, cssAnchorAligning
Anchors and Align work like Delphi. For example if Anchors property of
the control is [akLeft], it means fixed distance between left border of
parent's client area. [akRight] means fixed distance between right
border of the control and the right border of the parent's client area.
When the parent is resized the child is moved to keep the distance.
[akLeft,akRight] means fixed distance to left border and fixed distance
to right border. When the parent is resized, the controls width is
changed (resized) to keep the left and right distance.
Same for akTop,akBottom.
Align=alLeft for a control means set Left leftmost, Top topmost and
maximize Height. The width is kept, if akRight is not set. If akRight
is set in the Anchors property, then the right distance is kept and
the control's width is resized.
If there several controls with Align=alLeft, they will not overlapp and
be put side by side.
Same for alRight, alTop, alBottom. (Always expand 3 sides).
Align=alClient. The control will fill the whole remaining space.
Setting two childs to Align=alClient does only make sense, if you set
maximum Constraints.
Order: First all alTop childs are resized, then alBottom, then alLeft,
then alRight and finally alClient.
cesScaleChilds, cssScaleChilds
Scale childs, keep space between them fixed.
Childs are resized to their normal/adviced size. If there is some space
left in the client area of the parent, then the childs are scaled to
fill the space. You can set maximum Constraints. Then the other childs
are scaled more.
For example: 3 child controls A, B, C with A.Width=10, B.Width=20 and
C.Width=30 (total=60). If the Parent's client area has a ClientWidth of
120, then the childs are scaled with Factor 2.
If B has a maximum constraint width of 30, then first the childs will be
scaled with 1.5 (A.Width=15, B.Width=30, C.Width=45). Then A and C
(15+45=60 and 30 pixel space left) will be scaled by 1.5 again, to a
final result of: A.Width=23, B.Width=30, C.Width=67 (23+30+67=120).
cesHomogenousChildGrowth, cssHomogenousChildDecrease
Enlarge childs equally.
Childs are resized to their normal/adviced size. If there is some space
left in the client area of the parent, then the remaining space is
distributed equally to each child.
For example: 3 child controls A, B, C with A.Width=10, B.Width=20 and
C.Width=30 (total=60). If the Parent's client area has a ClientWidth of
120, then 60/3=20 is added to each Child.
If B has a maximum constraint width of 30, then first 10 is added to
all childs (A.Width=20, B.Width=30, C.Width=40). Then A and C
(20+40=60 and 30 pixel space left) will get 30/2=15 additional,
resulting in: A.Width=35, B.Width=30, C.Width=55 (35+30+55=120).
cesHomogenousSpaceGrowth
Enlarge space between childs equally.
Childs are resized to their normal/adviced size. If there is some space
left in the client area of the parent, then the space between the childs
if expanded.
For example: 3 child controls A, B, C with A.Width=10, B.Width=20 and
C.Width=30 (total=60). If the Parent's client area has a ClientWidth of
120, then there will be 60/2=30 space between A and B and between
B and C.
}
TChildControlEnlargeStyle = (
cesAnchorAligning, // (like Delphi)
cesScaleChilds, // scale childs, keep space between childs fixed
cesHomogenousChildGrowth, // enlarge childs equally
cesHomogenousSpaceGrowth // enlarge space between childs equally
);
TChildControlShrinkStyle = (
cssAnchorAligning, // (like Delphi)
cssScaleChilds, // scale childs
cssHomogenousChildDecrease // shrink childs equally
);
TControlChildSizing = class(TPersistent)
private
FControl: TControl;
FEnlargeHorizontal: TChildControlEnlargeStyle;
FEnlargeVertical: TChildControlEnlargeStyle;
FHorizontalSpacing: integer;
FLeftRightSpacing: integer;
FOnChange: TNotifyEvent;
FShrinkHorizontal: TChildControlShrinkStyle;
FShrinkVertical: TChildControlShrinkStyle;
FTopBottomSpacing: integer;
FVerticalSpacing: integer;
procedure SetEnlargeHorizontal(const AValue: TChildControlEnlargeStyle);
procedure SetEnlargeVertical(const AValue: TChildControlEnlargeStyle);
procedure SetHorizontalSpacing(const AValue: integer);
procedure SetLeftRightSpacing(const AValue: integer);
procedure SetShrinkHorizontal(const AValue: TChildControlShrinkStyle);
procedure SetShrinkVertical(const AValue: TChildControlShrinkStyle);
procedure SetTopBottomSpacing(const AValue: integer);
procedure SetVerticalSpacing(const AValue: integer);
protected
procedure Change; dynamic;
public
constructor Create(OwnerControl: TControl);
procedure Assign(Source: TPersistent); override;
procedure AssignTo(Dest: TPersistent); override;
function IsEqual(Sizing: TControlChildSizing): boolean;
public
property Control: TControl read FControl;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
published
property LeftRightSpacing: integer read FLeftRightSpacing write SetLeftRightSpacing;
property TopBottomSpacing: integer read FTopBottomSpacing write SetTopBottomSpacing;
property HorizontalSpacing: integer read FHorizontalSpacing write SetHorizontalSpacing;
property VerticalSpacing: integer read FVerticalSpacing write SetVerticalSpacing;
property EnlargeHorizontal: TChildControlEnlargeStyle read FEnlargeHorizontal
write SetEnlargeHorizontal default cesAnchorAligning;
property EnlargeVertical: TChildControlEnlargeStyle read FEnlargeVertical
write SetEnlargeVertical default cesAnchorAligning;
property ShrinkHorizontal: TChildControlShrinkStyle read FShrinkHorizontal
write SetShrinkHorizontal default cssAnchorAligning;
property ShrinkVertical: TChildControlShrinkStyle read FShrinkVertical
write SetShrinkVertical default cssAnchorAligning;
end;
{ TWinControlActionLink }
@ -1008,6 +1212,7 @@ type
FBoundsRealized: TRect;
FBrush: TBrush;
FAdjustClientRectRealized: TRect;
FChildSizing: TControlChildSizing;
FControls: TList;
FDefWndProc: Pointer;
//FDockSite: Boolean;
@ -1047,6 +1252,7 @@ type
function GetIsResizing: boolean;
function GetTabOrder: TTabOrder;
function GetVisibleDockClientCount: Integer;
procedure SetChildSizing(const AValue: TControlChildSizing);
procedure SetDockSite(const AValue: Boolean);
procedure SetHandle(NewHandle: HWND);
Procedure SetBorderWidth(Value : TBorderWidth);
@ -1060,6 +1266,7 @@ type
procedure AdjustSize; override;
procedure AdjustClientRect(var Rect: TRect); virtual;
procedure AlignControls(AControl : TControl; var ARect: TRect); virtual;
procedure DoChildSizingChange(Sender: TObject); virtual;
Function CanTab: Boolean; override;
Procedure CMDrag(var Message : TCMDrag); message CM_DRAG;
procedure CMShowingChanged(var Message: TLMessage); message CM_SHOWINGCHANGED;
@ -1152,11 +1359,12 @@ type
function IsControlMouseMsg(var TheMessage : TLMMouse): Boolean;
procedure FontChanged(Sender: TObject); override;
procedure SetColor(Value : TColor); override;
procedure SetZOrderPosition(Position: Integer); override;
procedure SetZOrderPosition(NewPosition: Integer); override;
procedure SetZOrder(Topmost: Boolean); override;
procedure SendMoveSizeMessages(SizeChanged, PosChanged: boolean); override;
public
property BorderWidth : TBorderWidth read FBorderWidth write SetBorderWidth default 0;
property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth default 0;
property ChildSizing: TControlChildSizing read FChildSizing write SetChildSizing;
property DefWndProc: Pointer read FDefWndProc write FDefWndPRoc;
property DockClientCount: Integer read GetDockClientCount;
property DockClients[Index: Integer]: TControl read GetDockClients;
@ -1207,11 +1415,13 @@ type
Procedure DisableAlign;
Procedure EnableAlign;
Procedure Invalidate; override;
Procedure RemoveControl(AControl : TControl);
Procedure InsertControl(AControl : TControl);
Procedure Insert(AControl : TControl);
Procedure Remove(AControl : TControl);
procedure SetBounds(aLeft, aTop, aWidth, aHeight : integer); override;
Procedure InsertControl(AControl: TControl);
Procedure InsertControl(AControl: TControl; Index: integer);
Procedure RemoveControl(AControl: TControl);
Procedure Insert(AControl: TControl);
Procedure Insert(AControl: TControl; Index: integer);
Procedure Remove(AControl: TControl);
procedure SetBounds(aLeft, aTop, aWidth, aHeight: integer); override;
procedure Hide;
procedure Repaint; override;
Procedure SetFocus; override;
@ -1887,6 +2097,204 @@ end;
{$I mouse.inc}
{$I dragobject.inc}
{ TControlBorderSpacing }
procedure TControlBorderSpacing.SetAround(const AValue: TSpacingSize);
begin
if FAround=AValue then exit;
FAround:=AValue;
Change;
end;
procedure TControlBorderSpacing.SetBottom(const AValue: TSpacingSize);
begin
if FBottom=AValue then exit;
FBottom:=AValue;
Change;
end;
procedure TControlBorderSpacing.SetLeft(const AValue: TSpacingSize);
begin
if FLeft=AValue then exit;
FLeft:=AValue;
Change;
end;
procedure TControlBorderSpacing.SetRight(const AValue: TSpacingSize);
begin
if FRight=AValue then exit;
FRight:=AValue;
Change;
end;
procedure TControlBorderSpacing.SetTop(const AValue: TSpacingSize);
begin
if FTop=AValue then exit;
FTop:=AValue;
Change;
end;
constructor TControlBorderSpacing.Create(OwnerControl: TControl);
begin
FControl:=OwnerControl;
inherited Create;
end;
procedure TControlBorderSpacing.Assign(Source: TPersistent);
var
SrcSpacing: TControlBorderSpacing;
begin
if Source is TControlBorderSpacing then begin
SrcSpacing:=TControlBorderSpacing(Source);
if IsEqual(SrcSpacing) then exit;
FAround:=SrcSpacing.Around;
FBottom:=SrcSpacing.Bottom;
FLeft:=SrcSpacing.Left;
FRight:=SrcSpacing.Right;
FTop:=SrcSpacing.Top;
Change;
end else
inherited Assign(Source);
end;
procedure TControlBorderSpacing.AssignTo(Dest: TPersistent);
begin
Dest.Assign(Self);
end;
function TControlBorderSpacing.IsEqual(Spacing: TControlBorderSpacing
): boolean;
begin
Result:=(FAround=Spacing.Around)
and (FBottom=Spacing.Bottom)
and (FLeft=Spacing.Left)
and (FRight=Spacing.Right)
and (FTop=Spacing.Top);
end;
procedure TControlBorderSpacing.Change;
begin
if Assigned(FOnChange) then FOnChange(Self);
end;
{ TControlChildSizing }
procedure TControlChildSizing.SetEnlargeHorizontal(
const AValue: TChildControlEnlargeStyle);
begin
if FEnlargeHorizontal=AValue then exit;
FEnlargeHorizontal:=AValue;
Change;
end;
procedure TControlChildSizing.SetEnlargeVertical(
const AValue: TChildControlEnlargeStyle);
begin
if FEnlargeVertical=AValue then exit;
FEnlargeVertical:=AValue;
Change;
end;
procedure TControlChildSizing.SetHorizontalSpacing(const AValue: integer);
begin
if FHorizontalSpacing=AValue then exit;
FHorizontalSpacing:=AValue;
Change;
end;
procedure TControlChildSizing.SetLeftRightSpacing(const AValue: integer);
begin
if FLeftRightSpacing=AValue then exit;
FLeftRightSpacing:=AValue;
Change;
end;
procedure TControlChildSizing.SetShrinkHorizontal(
const AValue: TChildControlShrinkStyle);
begin
if FShrinkHorizontal=AValue then exit;
FShrinkHorizontal:=AValue;
Change;
end;
procedure TControlChildSizing.SetShrinkVertical(
const AValue: TChildControlShrinkStyle);
begin
if FShrinkVertical=AValue then exit;
FShrinkVertical:=AValue;
Change;
end;
procedure TControlChildSizing.SetTopBottomSpacing(const AValue: integer);
begin
if FTopBottomSpacing=AValue then exit;
FTopBottomSpacing:=AValue;
Change;
end;
procedure TControlChildSizing.SetVerticalSpacing(const AValue: integer);
begin
if FVerticalSpacing=AValue then exit;
FVerticalSpacing:=AValue;
Change;
end;
constructor TControlChildSizing.Create(OwnerControl: TControl);
begin
FControl:=OwnerControl;
inherited Create;
FEnlargeHorizontal:=cesAnchorAligning;
FEnlargeVertical:=cesAnchorAligning;
FShrinkHorizontal:=cssAnchorAligning;
FShrinkVertical:=cssAnchorAligning;
end;
procedure TControlChildSizing.Assign(Source: TPersistent);
var
SrcSizing: TControlChildSizing;
begin
if Source is TControlChildSizing then begin
SrcSizing:=TControlChildSizing(Source);
if IsEqual(SrcSizing) then exit;
FEnlargeHorizontal:=SrcSizing.EnlargeHorizontal;
FEnlargeVertical:=SrcSizing.EnlargeVertical;
FShrinkHorizontal:=SrcSizing.ShrinkHorizontal;
FShrinkVertical:=SrcSizing.ShrinkVertical;
FEnlargeHorizontal:=SrcSizing.EnlargeHorizontal;
FEnlargeVertical:=SrcSizing.EnlargeVertical;
FShrinkHorizontal:=SrcSizing.ShrinkHorizontal;
FShrinkVertical:=SrcSizing.ShrinkVertical;
Change;
end else
inherited Assign(Source);
end;
procedure TControlChildSizing.AssignTo(Dest: TPersistent);
begin
Dest.Assign(Self);
end;
function TControlChildSizing.IsEqual(Sizing: TControlChildSizing): boolean;
begin
Result:=(FEnlargeHorizontal=Sizing.EnlargeHorizontal)
and (FEnlargeVertical=Sizing.EnlargeVertical)
and (FShrinkHorizontal=Sizing.ShrinkHorizontal)
and (FShrinkVertical=Sizing.ShrinkVertical)
and (FEnlargeHorizontal=Sizing.EnlargeHorizontal)
and (FEnlargeVertical=Sizing.EnlargeVertical)
and (FShrinkHorizontal=Sizing.ShrinkHorizontal)
and (FShrinkVertical=Sizing.ShrinkVertical);
end;
procedure TControlChildSizing.Change;
begin
if Assigned(FOnChange) then FOnChange(Self);
end;
initialization
//writeln('controls.pp - initialization');
@ -1904,6 +2312,9 @@ end.
{ =============================================================================
$Log$
Revision 1.175 2004/02/13 15:49:54 mattias
started advanced LCL auto sizing
Revision 1.174 2004/02/12 18:09:10 mattias
removed win32 specific TToolBar code in new TToolBar, implemented TWinControl.FlipChildren

79
lcl/include/control.inc
View File

@ -757,6 +757,11 @@ begin
AdjustSize;
end;
procedure TControl.DoBorderSpacingChange(Sender: TObject);
begin
AdjustSize;
end;
{------------------------------------------------------------------------------
procedure TControl.SendMoveSizeMessages(SizeChanged, PosChanged: boolean);
------------------------------------------------------------------------------}
@ -1367,6 +1372,12 @@ begin
MouseUp(Button, KeysToShiftState(Keys), XPos, YPos);
end;
procedure TControl.SetBorderSpacing(const AValue: TControlBorderSpacing);
begin
if FBorderSpacing=AValue then exit;
FBorderSpacing.Assign(AValue);
end;
{------------------------------------------------------------------------------
Method: TControl.WMLButtonDown
Params: Message
@ -2344,24 +2355,23 @@ end;
{ TControl.SetZOrder
}
{------------------------------------------------------------------------------}
Procedure TControl.SetZOrder(Topmost : Boolean);
var AParent : TWinControl;
AControl : TControl;
Procedure TControl.SetZOrder(Topmost: Boolean);
begin
//if FParent <> nil then
// if Topmost then SetZOrderPosition(FParent.FControls.Count-1)
// else
// SetZOrderPosition(0);
if Parent <> nil then begin
if FParent = nil then exit;
if Topmost then
SetZOrderPosition(Parent.ControlCount-1)
else
SetZOrderPosition(0);
{if Parent <> nil then begin
AParent:= Parent;
{ Just reinsert the control on top. Don't if it already is }
Just reinsert the control on top. Don't if it already is
if Topmost then begin
if (AParent.Controls[AParent.ControlCount - 1] <> Self) then begin
AParent.RemoveControl(Self);
AParent.InsertControl(Self);
end;
end else begin
{ Move all other controls over this one }
// Move all other controls over this one
if (AParent.Controls[0] <> Self) then begin
AParent.RemoveControl(Self);
AParent.InsertControl(Self);
@ -2372,7 +2382,7 @@ begin
end;
end;
end;
end;
end; }
end;
{------------------------------------------------------------------------------
@ -2449,27 +2459,32 @@ begin
end;
{------------------------------------------------------------------------------
TControl.SetZOrderPosition
TControl.SetZOrderPosition
Set the position of the child control in the Controls list of its parent.
TWinControl overrides this and will position itself in the FWinControls
while this function position itself in the FControls list.
Notes:
The FControls are always below the FWinControls.
TWinControl overrides this and will position itself in the FWinControls
list.
------------------------------------------------------------------------------}
Procedure TControl.SetZOrderPosition(Position: Integer);
Procedure TControl.SetZOrderPosition(NewPosition: Integer);
Var
I : Integer;
Count : Integer;
OldPosition: Integer;
Count: Integer;
begin
if FParent <> nil then
Begin
I := FParent.FControls.Indexof(self);
if I >= 0 then
begin
Count := FParent.FControls.Count;
if Position < 0 then Position := 0;
if Position >= Count then Position := Count-1;
if Position <> I then
begin
FParent.FControls.Delete(i);
FParent.FControls.Insert(Position,Self);
InvalidateControl(Visible,True,True);
end;
if Parent = nil then exit;
OldPosition := FParent.FControls.IndexOf(self);
if (OldPosition >= 0) then
begin
Count := FParent.FControls.Count;
if NewPosition < 0 then NewPosition := 0;
if NewPosition >= Count then NewPosition := Count-1;
if NewPosition <> OldPosition then begin
FParent.FControls.Move(OldPosition,NewPosition);
InvalidateControl(Visible,True,True);
end;
end;
end;
@ -2542,6 +2557,7 @@ begin
Application.ControlDestroyed(Self);
SetParent(nil);
FreeThenNil(FActionLink);
FreeThenNil(FBorderSpacing);
FreeThenNil(FConstraints);
FreeThenNil(FFont);
//writeln('[TControl.Destroy] B ',Name,':',ClassName);
@ -2568,6 +2584,8 @@ begin
csOpaque];
FConstraints:= TSizeConstraints.Create(Self);
FConstraints.OnChange:= @DoConstraintsChange;
FBorderSpacing:=TControlBorderSpacing.Create(Self);
FBorderSpacing.OnChange:= @DoBorderSpacingChange;
FAnchors := [akLeft,akTop];
FAlign := alNone;
@ -2735,6 +2753,9 @@ end;
{ =============================================================================
$Log$
Revision 1.168 2004/02/13 15:49:54 mattias
started advanced LCL auto sizing
Revision 1.167 2004/02/04 23:30:18 mattias
completed TControl actions

21
lcl/include/controlsproc.inc
View File

@ -1,3 +1,5 @@
// included by controls.pp
{
*****************************************************************************
* *
@ -27,25 +29,24 @@ End;
Function ListIndexOf(var List : TList; Item: Pointer) : Longint;
Begin
Result := -1;
if List = nil then exit;
Result := List.IndexOf(Item);
if List <> nil then Result := List.IndexOf(Item);
End;
Function ListCount(List : TList) : Longint;
Begin
Result := 0;
if List = nil then exit;
Result := List.Count;
if List <> nil then Result := List.Count;
End;
Procedure ListRemove(var List : TList; Item: Pointer);
Begin
if List=nil then exit;
List.Remove(Item);
if List.Count = 0 then
Begin
List.Free;
List := nil;
End;
if List.Count = 0 then begin
List.Free;
List := nil;
End;
End;
// included by controls.pp

6
lcl/include/sizeconstraints.inc
View File

@ -169,6 +169,12 @@ begin
end;
end;
procedure TSizeConstraints.SetOptions(const AValue: TSizeConstraintsOptions);
begin
if FOptions=AValue then exit;
FOptions:=AValue;
end;
{------------------------------------------------------------------------------
Method: TSizeConstraints.Change
Params: none

19
lcl/include/toolbutton.inc
View File

@ -168,19 +168,6 @@ begin
inherited Paint;
end;
procedure TToolButton.ChangeBounds(NewLeft, NewTop, NewWidth, NewHeight: Integer);
begin
if ((NewLeft=Left) and (NewTop=Top) and (NewWidth=Width) and (NewHeight=Height))
or (FUpdateCount>0) or ([csLoading,csDestroying]*ComponentState<>[])
or (FToolBar=nil) or (not FToolBar.HandleAllocated) then
begin
inherited ChangeBounds(NewLeft, NewTop, NewWidth, NewHeight);
exit;
end;
// ToDo
end;
function TToolButton.CalculateButtonState: Word;
begin
Result := 0;
@ -338,7 +325,6 @@ end;
procedure TToolButton.EndUpdate;
begin
Dec(FUpdateCount);
// ToDo: update changed
end;
function TToolButton.GetIndex: Integer;
@ -356,7 +342,7 @@ end;
procedure TToolButton.RefreshControl;
begin
UpdateVisibleToolbar;
UpdateControl;
end;
procedure TToolButton.UpdateControl;
@ -902,6 +888,9 @@ end;
{
$Log$
Revision 1.8 2004/02/13 15:49:54 mattias
started advanced LCL auto sizing
Revision 1.7 2004/02/12 18:09:10 mattias
removed win32 specific TToolBar code in new TToolBar, implemented TWinControl.FlipChildren

171
lcl/include/wincontrol.inc
View File

@ -519,6 +519,11 @@ begin
if Showing then AdjustSize;
end;
procedure TWinControl.DoChildSizingChange(Sender: TObject);
begin
AdjustSize;
end;
Procedure TWinControl.DoAutoSize;
var
I : Integer;
@ -965,13 +970,13 @@ const
var
i: integer;
begin
if FParent <> nil then
begin
if FParent <> nil then begin
if TopMost then
i := FParent.FWinControls.Count - 1
else
i := 0;
if FParent.FControls <> nil then inc(i, FParent.FControls.Count);
if FParent.FControls <> nil then
inc(i, FParent.FControls.Count);
SetZOrderPosition(i);
end
else if HandleAllocated then begin
@ -1024,16 +1029,6 @@ begin
end;
WindowProc(TLMessage(MoveMsg));
end;
{// Flags := SWP_NOZORDER or SWP_NOACTIVATE;
Flags := $14;
if not SizeChanged then
// Flags := Flags or SWP_NOSIZE
Flags := Flags or $1
else
// if not PosChanged then
// Flags := Flags or SWP_NOMOVE;
Flags := Flags or $2;
SetWindowPos(Handle, 0, FLeft, FTop, FWidth, FHeight, Flags);}
end;
{------------------------------------------------------------------------------}
@ -1078,38 +1073,39 @@ begin
end;
{-------------------------------------------------------------------------------
procedure TWinControl.SetZOrderPosition(Position: Integer);
procedure TWinControl.SetZOrderPosition(NewPosition: Integer);
-------------------------------------------------------------------------------}
procedure TWinControl.SetZOrderPosition(Position: Integer);
procedure TWinControl.SetZOrderPosition(NewPosition: Integer);
var
I, Count: Integer;
OldPosition, Count: Integer;
Pos: HWND;
begin
if FParent <> nil then
begin
if FParent.FControls <> nil then
Dec(Position, FParent.FControls.Count);
I := FParent.FWinControls.IndexOf(Self);
if I >= 0 then
Dec(NewPosition, FParent.FControls.Count);
OldPosition := FParent.FWinControls.IndexOf(Self);
if OldPosition >= 0 then
begin
Count := FParent.FWinControls.Count;
if Position < 0 then Position := 0;
if Position >= Count then Position := Count - 1;
if Position <> I then
if NewPosition < 0 then NewPosition := 0;
if NewPosition >= Count then NewPosition := Count - 1;
if NewPosition <> OldPosition then
begin
FParent.FWinControls.Delete(I);
FParent.FWinControls.Insert(Position, Self);
FParent.FWinControls.Move(OldPosition,NewPosition);
end;
end;
if HandleAllocated then
begin
if Position = 0 then Pos := HWND_BOTTOM
else if Position = FParent.FWinControls.Count - 1 then Pos := HWND_TOP
else if Position > I then
Pos := TWinControl(FParent.FWinControls[Position + 1]).Handle
else if Position < I then
Pos := TWinControl(FParent.FWinControls[Position]).Handle
if NewPosition = 0 then
Pos := HWND_BOTTOM
else if NewPosition = FParent.FWinControls.Count - 1 then
Pos := HWND_TOP
else if NewPosition > OldPosition then
Pos := TWinControl(FParent.FWinControls[NewPosition + 1]).Handle
else if NewPosition < OldPosition then
Pos := TWinControl(FParent.FWinControls[NewPosition]).Handle
else Exit;
SetWindowPos(Handle, Pos, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE);
end;
@ -1693,37 +1689,34 @@ end;
-------------------------------------------------------------------------------}
procedure TWinControl.SetControlIndex(AControl: TControl; NewIndex: integer);
begin
if AControl<>nil then
AControl.SetZOrderPosition(NewIndex);
if AControl=nil then exit;
AControl.SetZOrderPosition(NewIndex);
end;
{------------------------------------------------------------------------------}
{ TWinControl DestroyHandle }
{------------------------------------------------------------------------------}
procedure TWinControl.DestroyHandle;
var i : integer;
var
i: integer;
AWinControl: TWinControl;
begin
if not HandleAllocated then begin
writeln('Warning: TWinControl.DestroyHandle ',Name,':',ClassName,' Handle not Allocated');
// create an gdb catchable exception:
// if (length(Name) div (length(Name) div 10000))=0 then ;
//RaiseGDBException('');
end;
{ Destroy all children handles, too }
{ If we don't do that, GTK does this without notification for us and we crash }
{ TODO : We can enable HandleAllocated condition only when all controls, especially
TNotebook / TPage set their Handles correctly, i.e. mirror the GTK behavior }
// if HandleAllocated then begin
if FWinControls <> nil then begin
for i:= 0 to FWinControls.Count - 1 do begin
//writeln(' i=',i);
//writeln(' ',TWinControl(FWinControls[i]).Name,':',TWinControl(FWinControls[i]).ClassName);
if TWinControl(FWinControls[i]).HandleAllocated then
TWinControl(FWinControls[i]).DestroyHandle;
end;
// First destroy all children handles
if FWinControls <> nil then begin
for i:= 0 to FWinControls.Count - 1 do begin
//writeln(' i=',i);
//writeln(' ',TWinControl(FWinControls[i]).Name,':',TWinControl(FWinControls[i]).ClassName);
AWinControl:=TWinControl(FWinControls[i]);
if AWinControl.HandleAllocated then
AWinControl.DestroyHandle;
end;
DestroyWnd;
// end;
end;
DestroyWnd;
end;
{------------------------------------------------------------------------------
@ -2133,31 +2126,41 @@ end;
{------------------------------------------------------------------------------}
procedure TWinControl.Insert(AControl : TControl);
begin
if AControl <> nil then
begin
if AControl = Self
then begin
Assert(False, 'Trace:[TControl.SetParent] EInvalidOperation --> AControl = Self');
raise EInvalidOperation.Create(rsAControlCanNotHaveItselfAsParent);
end;
if AControl is TWinControl then
begin
ListAdd(FWinControls, AControl);
ListAdd(FTabList, AControl);
end else
ListAdd(FControls, AControl);
AControl.FParent := Self;
If (csDesigning in ComponentState)
and not (csLoading in ComponentState)
then
If AControl.CanTab then
AControl.TabStop := True;
end;
Insert(AControl,ControlCount);
End;
{------------------------------------------------------------------------------
procedure TWinControl.Insert(AControl: TControl; Index: integer);
------------------------------------------------------------------------------}
procedure TWinControl.Insert(AControl: TControl; Index: integer);
begin
if AControl = nil then exit;
if AControl = Self then
raise EInvalidOperation.Create(rsAControlCanNotHaveItselfAsParent);
if AControl is TWinControl then
begin
if (FControls<>nil) then dec(Index,FControls.Count);
if (FWinControls<>nil) and (Index<FWinControls.Count) then
FWinControls.Insert(Index,AControl)
else
ListAdd(FWinControls, AControl);
ListAdd(FTabList, AControl);
end else begin
if (FControls<>nil) and (Index<FControls.Count) then
FControls.Insert(Index,AControl)
else
ListAdd(FControls, AControl);
end;
AControl.FParent := Self;
If (csDesigning in ComponentState) and (not (csLoading in ComponentState))
and AControl.CanTab then
AControl.TabStop := True;
end;
{------------------------------------------------------------------------------
TWinControl ReAlign
@ -2229,9 +2232,14 @@ end;
{------------------------------------------------------------------------------}
Procedure TWinControl.InsertControl(AControl : TControl);
Begin
InsertControl(AControl,ControlCount);
End;
procedure TWinControl.InsertControl(AControl: TControl; Index: integer);
begin
AControl.ValidateContainer(Self);
Perform(CM_CONTROLLISTCHANGE, WParam(AControl), LParam(True));
Insert(AControl);
Insert(AControl,Index);
if not (csReadingState in AControl.ControlState) then
begin
AControl.Perform(CM_PARENTCOLORCHANGED, 0, 0);
@ -2248,7 +2256,7 @@ Begin
end;
AControl.RequestAlign;
Perform(CM_CONTROLCHANGE, WParam(AControl), LParam(True));
End;
end;
{------------------------------------------------------------------------------}
{ TWinControl removeControl }
@ -2407,6 +2415,8 @@ constructor TWinControl.Create(TheOwner : TComponent);
begin
inherited Create(TheOwner);
FCompStyle := csFixed;
FChildSizing:=TControlChildSizing.Create(Self);
FChildSizing.OnChange:=@DoChildSizingChange;
FBrush := nil; // Brush will be created on demand. Only few controls need it.
end;
@ -2473,8 +2483,8 @@ begin
n := ControlCount;
end;
FBrush.Free;
FBrush:=nil;
FreeThenNil(FBrush);
FreeThenNil(FChildSizing);
//writeln('[TWinControl.Destroy] D ',Name,':',ClassName);
inherited Destroy;
//writeln('[TWinControl.Destroy] END ',Name,':',ClassName);
@ -3172,6 +3182,12 @@ begin
Result:=0;
end;
procedure TWinControl.SetChildSizing(const AValue: TControlChildSizing);
begin
if FChildSizing=AValue then exit;
FChildSizing.Assign(AValue);
end;
procedure TWinControl.SetDockSite(const AValue: Boolean);
begin
if FDockSite=AValue then exit;
@ -3354,6 +3370,9 @@ end;
{ =============================================================================
$Log$
Revision 1.201 2004/02/13 15:49:54 mattias
started advanced LCL auto sizing
Revision 1.200 2004/02/12 18:09:10 mattias
removed win32 specific TToolBar code in new TToolBar, implemented TWinControl.FlipChildren

15
lcl/interfaces/gtk/gtkcallback.inc
View File

@ -623,7 +623,7 @@ begin
if GtkWidgetIsA(Widget,gtk_window_get_type) then begin
FocusedWidget:=PGtkWindow(Widget)^.focus_widget;
if FocusedWidget<>nil then begin
LCLObject:=GetParentLCLObject(FocusedWidget);
LCLObject:=GetNearestLCLObject(FocusedWidget);
if LCLObject is TWinControl then begin
FocusedWinControl:=TWinControl(LCLObject);
if FocusedWidget<>Widget then begin
@ -1419,8 +1419,9 @@ begin
if not ControlGetsMouseDownBefore(TControl(Data)) then exit;
// grabbing for TSplitter -> Maybe ths is the key for drag&drop
if TWinControl(Data) is TCustomSplitter then begin
CaptureWidget:=PGtkWidget(TCustomSplitter(Data).Handle);
CaptureWidget:=PGtkWidget(TWinControl(Data).Handle);
if (GtkWidgetIsA(CaptureWidget,GTKAPIWidget_GetType))
or (TWinControl(Data) is TCustomSplitter) then begin
CaptureWidget:=GetWidgetInfo(CaptureWidget,true)^.ImplementationWidget;
if not gtk_widget_has_focus(CaptureWidget) then
gtk_widget_grab_focus(CaptureWidget);
@ -1586,8 +1587,9 @@ begin
if not (csDesigning in TComponent(Data).ComponentState) then begin
DesignOnlySignal:=GetDesignOnlySignalFlag(Widget,dstMouseRelease);
if TWinControl(Data) is TCustomSplitter then begin
CaptureWidget:=PGtkWidget(TCustomSplitter(Data).Handle);
CaptureWidget:=PGtkWidget(TWinControl(Data).Handle);
if GtkWidgetIsA(CaptureWidget,GTKAPIWidget_GetType)
or (TWinControl(Data) is TCustomSplitter) then begin
CaptureWidget:=GetWidgetInfo(CaptureWidget,true)^.ImplementationWidget;
if Event^.button=1 then
gtk_grab_remove(CaptureWidget);
@ -3069,6 +3071,9 @@ end;
{ =============================================================================
$Log$
Revision 1.219 2004/02/13 15:49:54 mattias
started advanced LCL auto sizing
Revision 1.218 2004/02/07 18:04:14 mattias
fixed grids OnDrawCells

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

@ -4930,7 +4930,7 @@ begin
// if one of its widgets has the focus then unfocus
GtkWindow:=gtk_widget_get_toplevel(Widget);
if GtkWidgetIsA(GtkWindow,GTK_TYPE_WINDOW)
and (GetParentLCLObject(PGtkWindow(GtkWindow)^.Focus_Widget)=Sender)
and (GetNearestLCLObject(PGtkWindow(GtkWindow)^.Focus_Widget)=Sender)
then begin
gtk_window_set_focus(PGtkWindow(GtkWindow),nil);
end;
@ -9201,6 +9201,9 @@ end;
{ =============================================================================
$Log$
Revision 1.468 2004/02/13 15:49:54 mattias
started advanced LCL auto sizing
Revision 1.467 2004/02/12 18:09:10 mattias
removed win32 specific TToolBar code in new TToolBar, implemented TWinControl.FlipChildren

32
lcl/interfaces/gtk/gtkproc.inc
View File

@ -605,7 +605,7 @@ begin
Result:=HexStr(Cardinal(Widget),8);
if Widget=nil then exit;
Result:=Result+'='+GetWidgetClassName(Widget);
LCLObject:=GetParentLCLObject(Widget);
LCLObject:=GetNearestLCLObject(Widget);
Result:=Result+' LCLObject='+HexStr(Cardinal(LCLObject),8);
if LCLObject=nil then exit;
if LCLObject is TControl then
@ -720,7 +720,7 @@ var
IsAPIWidget: Boolean;
begin
MainWidget:=ChildWidget;
LCLObject:=GetParentLCLObject(ChildWidget);
LCLObject:=GetNearestLCLObject(ChildWidget);
if (LCLObject is TWinControl) then
MainWidget:=PGtkWidget(TWinControl(LCLObject).Handle);
IsAPIWidget:=GtkWidgetIsA(MainWidget,GTKAPIWidget_GetType);
@ -2716,26 +2716,27 @@ begin
RaiseInvalidFixedWidget;
end;
function GetParentWidget(Child: PGtkWidget): PGtkWidget;
function GetWinControlWidget(Child: PGtkWidget): PGtkWidget;
// return the first widget, which is associated with a TWinControl handle
var
LCLParent: TObject;
begin
Result:=nil;
LCLParent:=GetParentLCLObject(Child);
LCLParent:=GetNearestLCLObject(Child);
if (LCLParent=nil) or (not (LCLParent is TWinControl))
or (not TWinControl(LCLParent).HandleAllocated)
then exit;
Result:=PGtkWidget(TWinControl(LCLParent).Handle);
end;
function GetParentFixedWidget(Child: PGtkWidget): PGtkWidget;
function GetWinControlFixedWidget(Child: PGtkWidget): PGtkWidget;
begin
Result:=GetParentWidget(Child);
Result:=GetWinControlWidget(Child);
if Result=nil then exit;
Result:=GetFixedWidget(Result);
end;
function FindFixedChild(ParentFixed: PGtkFixed; Child: PGtkWidget): PGList;
function FindFixedChildListItem(ParentFixed: PGtkFixed; Child: PGtkWidget): PGList;
begin
Result:=ParentFixed^.children;
while (Result<>nil) do begin
@ -2745,11 +2746,23 @@ begin
end;
end;
function FindFixedLastChildListItem(ParentFixed: PGtkFixed): PGList;
begin
Result:=g_list_last(ParentFixed^.children);
end;
{------------------------------------------------------------------------------
procedure MoveGListLinkBehind(First, Item, After: PGList);
Move the list item 'Item' behind the list item 'After'.
If After=nil then insert as first item.
------------------------------------------------------------------------------}
procedure MoveGListLinkBehind(First, Item, After: PGList);
var
Data: Pointer;
NewPos: Integer;
begin
if (Item=After) or (Item^.Next=After) then exit;
if (g_list_position(First,Item)<0) then
RaiseException('MoveGListLinkBehind Item not found');
if (After<>nil) and (g_list_position(First,After)<0) then
@ -2947,7 +2960,7 @@ begin
Result := TObject(gtk_object_get_data(Widget, 'Class'));
end;
function GetParentLCLObject(Widget: PGtkWidget): TObject;
function GetNearestLCLObject(Widget: PGtkWidget): TObject;
begin
while (Widget<>nil) do begin
Result:=GetLCLObject(Widget);
@ -6307,6 +6320,9 @@ end;
{ =============================================================================
$Log$
Revision 1.259 2004/02/13 15:49:54 mattias
started advanced LCL auto sizing
Revision 1.258 2004/02/08 11:31:32 mattias
TMenuItem.Bitmap is now auto created on read. Added TMenuItem.HasBitmap

9
lcl/interfaces/gtk/gtkproc.pp
View File

@ -290,12 +290,13 @@ procedure FreeWinWidgetInfo(Widget: Pointer);
procedure DestroyWidget(Widget: PGtkWidget);
procedure SetLCLObject(const Widget: Pointer; const AnObject: TObject);
function GetLCLObject(const Widget: Pointer): TObject;
function GetParentLCLObject(Widget: PGtkWidget): TObject;
function GetNearestLCLObject(Widget: PGtkWidget): TObject;
procedure SetHiddenLCLObject(const Widget: Pointer; const AnObject: TObject);
function GetHiddenLCLObject(const Widget: Pointer): TObject;
function GetParentWidget(Child: PGtkWidget): PGtkWidget;
function GetParentFixedWidget(Child: PGtkWidget): PGtkWidget;
function FindFixedChild(ParentFixed: PGtkFixed; Child: PGtkWidget): PGList;
function GetWinControlWidget(Child: PGtkWidget): PGtkWidget;
function GetWinControlFixedWidget(Child: PGtkWidget): PGtkWidget;
function FindFixedChildListItem(ParentFixed: PGtkFixed; Child: PGtkWidget): PGList;
function FindFixedLastChildListItem(ParentFixed: PGtkFixed): PGList;
// fixed widgets
Procedure FixedMoveControl(Parent, Child : PGTKWIdget; Left, Top : Longint);

106
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -132,7 +132,7 @@ var
begin
{$IFDEF Gtk1}
Widget:=PGtkWidget(Handle);
TargetObject:=GetParentLCLObject(Widget);
TargetObject:=GetNearestLCLObject(Widget);
IsDoubleBuffered:=(TargetObject is TWinControl)
and TWinControl(TargetObject).DoubleBuffered;
// check if Handle is the paint widget of the LCL component
@ -7837,7 +7837,7 @@ begin
if (Screen<>nil)
and (Screen.FocusedForm<>nil)
and (fsModal in Screen.FocusedForm.FormState)
and (GetParentLCLObject(TopLevel)<>Screen.FocusedForm) then begin
and (GetNearestLCLObject(TopLevel)<>Screen.FocusedForm) then begin
{$IFDEF VerboseFocus}
writeln('[TgtkObject.SetFocus] there is a modal form -> not grabbing');
{$ENDIF}
@ -8146,17 +8146,80 @@ end;
function TgtkObject.SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND;
X, Y, cx, cy: Integer; uFlags: UINT): Boolean;
hWnd: Widget to move
hWndInsertAfter:
HWND_BOTTOM to move bottommost
HWND_TOP to move topmost
the Widget, that should ly just on top of hWnd
uFlags:
SWP_NOMOVE: ignore X, Y
SWP_NOSIZE: ignore cx, cy
SWP_NOZORDER: ignore hWndInsertAfter
SWP_NOREDRAW: skip instant redraw
SWP_NOACTIVATE: skip switching focus
------------------------------------------------------------------------------}
function TgtkObject.SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND;
X, Y, cx, cy: Integer; uFlags: UINT): Boolean;
var Widget: PGTKWidget;
{ FixedWidget: PGtkWidget;
OldListItem: PGList;
AfterWidget: PGtkWidget;
AfterListItem: PGList;}
procedure SetZOrderOnFixedWidget(Widget, FixedWidget: PGtkWidget);
var
OldListItem: PGList;
AfterWidget: PGtkWidget;
AfterListItem: PGList;
begin
OldListItem:=FindFixedChildListItem(PGtkFixed(FixedWidget),Widget);
if OldListItem=nil then begin
writeln('TgtkObject.SetWindowPos WARNING: Widget not on parents fixed widget');
exit;
end;
AfterWidget:=nil;
AfterListItem:=nil;
if hWndInsertAfter=HWND_BOTTOM then begin
// HWND_BOTTOM
end else if hWndInsertAfter=HWND_TOP then begin
// HWND_TOP
AfterListItem:=FindFixedLastChildListItem(PGtkFixed(FixedWidget));
end else begin
// hWndInsertAfter
AfterWidget:=PGtkWidget(hWndInsertAfter);
AfterListItem:=FindFixedChildListItem(PGtkFixed(FixedWidget),AfterWidget);
end;
if (AfterListItem=nil) and (AfterWidget<>nil) then begin
writeln('TgtkObject.SetWindowPos WARNING: AfterWidget not on parents fixed widget');
exit;
end;
if (OldListItem=AfterListItem) or (OldListItem^.next=AfterListItem) then
exit;
writeln('TgtkObject.SetWindowPos Moving GList entry');
// reorder
// This trick does not work properly
exit;
MoveGListLinkBehind(PGtkFixed(FixedWidget)^.children,
OldListItem,AfterListItem);
if GTK_WIDGET_VISIBLE(FixedWidget) and GTK_WIDGET_VISIBLE (Widget)
and GTK_WIDGET_MAPPED(Widget) then begin
gtk_widget_queue_resize(FixedWidget);
end;
end;
procedure SetZOrderOnLayoutWidget(Widget, LayoutWidget: PGtkWidget);
begin
writeln('ToDO: SetZOrderOnLayoutWidget');
end;
var
Widget: PGTKWidget;
FixedWidget: PGtkWidget;
begin
//writeln('[TgtkObject.SetWindowPos] Top=',hWndInsertAfter=HWND_TOP,' ');
Widget:=PGtkWidget(hWnd);
writeln('[TgtkObject.SetWindowPos] ',GetWidgetDebugReport(Widget),
' Top=',hWndInsertAfter=HWND_TOP,
' SWP_NOZORDER=',(SWP_NOZORDER and uFlags)<>0,
' SWP_NOSIZE=',(SWP_NOSIZE and uFlags)<>0,
' SWP_NOMOVE=',(SWP_NOMOVE and uFlags)<>0,
'');
if GtkWidgetIsA(Widget,GTK_TYPE_WINDOW) then begin
{ case hWndInsertAfter of
HWND_BOTTOM: ; //gdk_window_lower(Widget^.Window);
@ -8164,22 +8227,20 @@ begin
//gdk_window_raise(Widget^.Window);
end;
}
end else begin
{AfterWidget:=PGtkWidget(hWndInsertAfter);
FixedWidget:=GetParentFixedWidget(Widget);
end else if (SWP_NOZORDER and uFlags)=0 then begin
FixedWidget:=Widget^.Parent;
if FixedWidget=nil then exit;
OldListItem:=FindFixedChild(FixedWidget,Widget);
if OldListItem=nil then begin
writeln('TgtkObject.SetWindowPos WARNING: Widget not on parents fixed widget');
writeln('TgtkObject.SetWindowPos ZOrdering .. on ',GetWidgetDebugReport(FixedWidget));
if GtkWidgetIsA(FixedWidget,GTK_Fixed_Get_Type) then begin
// parent's client area is a gtk_fixed widget
SetZOrderOnFixedWidget(Widget,FixedWidget);
exit;
end else if GtkWidgetIsA(FixedWidget,GTK_Layout_Get_Type) then begin
// parent's client area is a gtk_layout widget
SetZOrderOnLayoutWidget(Widget,FixedWidget);
exit;
end;
AfterListItem:=FindFixedChild(FixedWidget,AfterWidget);
if (AfterListItem=nil) and (AfterWidget<>nil) then begin
writeln('TgtkObject.SetWindowPos WARNING: AfterWidget not on parents fixed widget');
exit;
end;
MoveGListLinkBehind(PGtkFixed(FixedWidget)^.children,
OldListItem,AfterListItem);}
end;
Result:=true;
end;
@ -8682,6 +8743,9 @@ end;
{ =============================================================================
$Log$
Revision 1.329 2004/02/13 15:49:54 mattias
started advanced LCL auto sizing
Revision 1.328 2004/02/10 00:05:03 mattias
TSpeedButton now uses MaskBlt

11
lcl/lcltype.pp
View File

@ -704,9 +704,9 @@ const
SWP_NOSIZE = 1;
SWP_NOMOVE = 2;
SWP_NOZORDER = 3;
SWP_NOREDRAW = 4;
SWP_NOACTIVATE = 5;
SWP_NOZORDER = 4;
SWP_NOREDRAW = 8;
SWP_NOACTIVATE = $10;
{ WMSIZE Message Constants}
Size_Restored = 0; // the default
@ -714,7 +714,7 @@ const
Size_Maximized = 2;
Size_MaxShow = 3;
Size_MaxHide = 4;
Size_SourceIsInterface = 128; // this is flag. Can be combined with the above
Size_SourceIsInterface = 128; // this is a flag. Can be combined with the above
SIZENORMAL = Size_Restored;
SIZEICONIC = Size_Minimized;
@ -1983,6 +1983,9 @@ end.
{
$Log$
Revision 1.58 2004/02/13 15:49:54 mattias
started advanced LCL auto sizing
Revision 1.57 2004/02/04 13:40:19 mattias
ShortCutToText now deletes any modifier