paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-14 07:02:50 +02:00
Code Issues Packages Projects Releases Wiki Activity
a3dac0b6df
lazarus/lcl/include/control.inc
paul a3dac0b6df lcl: redo context menu message handling: 
- when called by keyboard pass -1, -1 coords
  - remove child->parent loop from LCL to widgetsets (win32 and wince do this automatically, qt do it too if mouse propagation is on)
  - don't show parent context menu if child has own standard menu (like TEdit)
qt: redo mouse handling, turn on mouse propagation and mouse tracking for most of widgets, stop propagation in event filters
gtk2: implement context menu loop
widgetsets: remove LM_PRESSED, LM_RELEASED messages (LCL does not use them and they are not needed for any compatbility reasons)

git-svn-id: trunk@26637 -
2010-07-14 08:47:02 +00:00

4951 lines
158 KiB
PHP
Raw Blame History

{%MainUnit ../controls.pp}
{ $Id$ }
{******************************************************************************
TControl
******************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL.txt, 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. *
* *
*****************************************************************************
}
{$IFOPT C-}
// Uncomment for local trace
// {$C+}
// {$DEFINE ASSERT_IS_ON}
{$ENDIF}
{ $DEFINE CHECK_POSITION}
{------------------------------------------------------------------------------
TControl.AdjustSize
Calls DoAutoSize smart.
During loading and handle creation the calls are delayed.
This method does the same as TWinControl.DoAutoSize at the beginning.
But since DoAutoSize is commonly overriden by existing Delphi components,
they do not all tests, which can result in too much overhead. To reduce this
the LCL calls AdjustSize instead.
------------------------------------------------------------------------------}
procedure TControl.Adjustsize;
begin
{$IFDEF VerboseAdjustSize}
if (Parent=nil) and (not (cfAutoSizeNeeded in FControlFlags))
and (Self is TCustomForm) then begin
DebugLn(['TControl.Adjustsize ',DbgSName(Self)]);
end;
{$ENDIF}
Include(FControlFlags, cfAutoSizeNeeded);
if IsControlVisible then
begin
if Parent <> nil then
Parent.AdjustSize
else
if not AutoSizeDelayed then
DoAllAutoSize;
end;
end;
{------------------------------------------------------------------------------
Method: TControl.BeginDrag
Params: Immediate: Drag behaviour
Threshold: distance to move before dragging starts
-1 uses the default value of DragManager.DragThreshold
Returns: Nothing
Starts the dragging of a control. If the Immediate flag is set, dragging
starts immediately. A drag-dock should not normally start immediately!
------------------------------------------------------------------------------}
procedure TControl.BeginDrag(Immediate: Boolean; Threshold: Integer);
begin
DragManager.DragStart(Self, Immediate, Threshold);
end;
{------------------------------------------------------------------------------
TControl.BeginAutoDrag
------------------------------------------------------------------------------}
procedure TControl.BeginAutoDrag;
begin
debugln(['TControl.BeginAutoDrag ',DbgSName(Self)]);
BeginDrag(DragManager.DragImmediate, DragManager.DragThreshold);
end;
{------------------------------------------------------------------------------
TControl.BeginAutoSizing
------------------------------------------------------------------------------}
procedure TControl.BeginAutoSizing;
procedure Error;
begin
RaiseGDBException('TControl.BeginAutoSizing');
end;
begin
if FAutoSizingSelf then Error;
FAutoSizingSelf := True;
end;
{------------------------------------------------------------------------------
procedure TControl.DoEndDock(Target: TObject; X, Y: Integer);
------------------------------------------------------------------------------}
procedure TControl.DoEndDock(Target: TObject; X, Y: Integer);
begin
if Assigned(FOnEndDock) then
FOnEndDock(Self,Target,X,Y);
end;
{------------------------------------------------------------------------------
procedure TControl.DoDock(NewDockSite: TWinControl; var ARect: TRect);
------------------------------------------------------------------------------}
procedure TControl.DoDock(NewDockSite: TWinControl; var ARect: TRect);
begin
if (NewDockSite = nil) then Parent := nil;
if NewDockSite<>nil then begin
//DebugLn('TControl.DoDock BEFORE Adjusting ',DbgSName(Self),' ',dbgs(ARect));
// adjust new bounds, so that they at least fit into the client area of
// its parent
if NewDockSite.AutoSize then begin
case align of
alLeft,
alRight : ARect:=Rect(0,0,Width,NewDockSite.ClientHeight);
alTop,
alBottom : ARect:=Rect(0,0,NewDockSite.ClientWidth,Height);
else
ARect:=Rect(0,0,Width,Height);
end;
end else begin
LCLProc.MoveRectToFit(ARect, NewDockSite.GetLogicalClientRect);
// consider Align to increase chance the width/height is kept
case Align of
alLeft: OffsetRect(ARect,-ARect.Left,0);
alTop: OffsetRect(ARect,0,-ARect.Top);
alRight: OffsetRect(ARect,NewDockSite.ClientWidth-ARect.Right,0);
alBottom: OffsetRect(ARect,0,NewDockSite.ClientHeight-ARect.Bottom);
end;
end;
//DebugLn('TControl.DoDock AFTER Adjusting ',DbgSName(Self),' ',dbgs(ARect),' Align=',AlignNames[Align],' NewDockSite.ClientRect=',dbgs(NewDockSite.ClientRect));
end;
//debugln('TControl.DoDock BEFORE MOVE ',Name,' BoundsRect=',dbgs(BoundsRect),' NewRect=',dbgs(ARect));
if Parent<>NewDockSite then
BoundsRectForNewParent := ARect
else
BoundsRect := ARect;
//debugln('TControl.DoDock AFTER MOVE ',DbgSName(Self),' BoundsRect=',dbgs(BoundsRect),' TriedRect=',dbgs(ARect));
end;
{------------------------------------------------------------------------------
procedure TControl.DoStartDock(var DragObject: TDragObject);
------------------------------------------------------------------------------}
procedure TControl.DoStartDock(var DragObject: TDragObject);
begin
if Assigned(FOnStartDock) then
FOnStartDock(Self,TDragDockObject(DragObject));
end;
{------------------------------------------------------------------------------
function TControl.GetDockEdge(const MousePos: TPoint): TAlign;
Calculate the dock side depending on current MousePos.
Important: MousePos is relative to this control's Left, Top.
------------------------------------------------------------------------------}
function TControl.GetDockEdge(const MousePos: TPoint): TAlign;
var
BestDistance: Integer;
procedure FindMinDistance(CurAlign: TAlign; CurDistance: integer);
begin
if CurDistance<0 then
CurDistance:=-CurDistance;
if CurDistance>=BestDistance then exit;
Result:=CurAlign;
BestDistance:=CurDistance;
end;
begin
BestDistance:=High(Integer);
FindMinDistance(alLeft,MousePos.X);
FindMinDistance(alRight,Width-MousePos.X);
FindMinDistance(alTop,MousePos.Y);
FindMinDistance(alBottom,Height-MousePos.Y);
end;
{------------------------------------------------------------------------------
function TControl.GetDragImages: TDragImageList;
Returns Drag image list that will be used while drag opetations
------------------------------------------------------------------------------}
function TControl.GetDragImages: TDragImageList;
begin
Result := nil;
end;
{------------------------------------------------------------------------------
procedure TControl.PositionDockRect(DragDockObject: TDragDockObject);
------------------------------------------------------------------------------}
procedure TControl.PositionDockRect(DragDockObject: TDragDockObject);
var
WinDragTarget: TWinControl;
begin
with DragDockObject do
begin
if (DragTarget is TWinControl) and TWinControl(DragTarget).UseDockManager then
begin
WinDragTarget := TWinControl(DragTarget);
GetWindowRect(WinDragTarget.Handle, FDockRect);
if (WinDragTarget.DockManager <> nil) then
WinDragTarget.DockManager.PositionDockRect(DragDockObject);
end else
begin
with FDockRect do
begin
Left := DragPos.X;
Top := DragPos.Y;
Right := Left + Control.UndockWidth;
Bottom := Top + Control.UndockHeight;
end;
// let user adjust dock rect
AdjustDockRect(FDockRect);
end;
end;
end;
{------------------------------------------------------------------------------
TControl.BoundsChanged
------------------------------------------------------------------------------}
procedure TControl.BoundsChanged;
begin
{ Notifications can be performed here }
end;
{------------------------------------------------------------------------------
TControl.Bringtofront
------------------------------------------------------------------------------}
procedure TControl.BringToFront;
begin
SetZOrder(true);
end;
{------------------------------------------------------------------------------
TControl.CanTab
------------------------------------------------------------------------------}
function TControl.CanTab: Boolean;
begin
Result := False;
end;
{------------------------------------------------------------------------------
TControl.Change
------------------------------------------------------------------------------}
procedure TControl.Changed;
begin
Perform(CM_CHANGED, 0, LParam(self));
end;
{------------------------------------------------------------------------------
TControl.EditingDone
Called when user has finished editing. This procedure can be used by data
links to commit the changes.
For example:
- When focus switches to another control (default)
- When user selected another item
It's totally up to the control, what events will commit.
------------------------------------------------------------------------------}
procedure TControl.EditingDone;
begin
if Assigned(OnEditingDone) then OnEditingDone(Self);
end;
procedure TControl.FontChanged(Sender: TObject);
begin
FParentFont := False;
Invalidate;
Perform(CM_FONTCHANGED, 0, 0);
if AutoSize then
begin
InvalidatePreferredSize;
AdjustSize;
end;
end;
procedure TControl.ParentFontChanged;
begin
//kept for compatibility. The real work is done in CMParentFontChanged
end;
procedure TControl.SetAction(Value: TBasicAction);
begin
if (Value=Action) then exit;
//debugln('TControl.SetAction A ',Name,':',ClassName,' Old=',DbgS(Action),' New=',DbgS(Value));
if Value = nil then begin
ActionLink.Free;
ActionLink:=nil;
Exclude(FControlStyle, csActionClient);
end
else
begin
Include(FControlStyle, csActionClient);
if ActionLink = nil then
ActionLink := GetActionLinkClass.Create(Self);
ActionLink.Action := Value;
ActionLink.OnChange := @DoActionChange;
ActionChange(Value, csLoading in Value.ComponentState);
Value.FreeNotification(Self);
end;
end;
{------------------------------------------------------------------------------
TControl.ChangeBounds
------------------------------------------------------------------------------}
procedure TControl.ChangeBounds(ALeft, ATop, AWidth, AHeight: integer;
KeepBase: boolean);
var
SizeChanged, PosChanged : boolean;
OldLeft: Integer;
OldTop: Integer;
OldWidth: Integer;
OldHeight: Integer;
NewBounds: TRect;
function PosSizeKept: boolean;
begin
SizeChanged:= (FWidth <> OldWidth) or (FHeight <> OldHeight);
PosChanged:= (FLeft <> OldLeft) or (FTop <> OldTop);
Result:=(not SizeChanged) and (not PosChanged);
end;
begin
{$IFDEF VerboseSizeMsg}
DebugLn(['TControl.ChangeBounds A ',DbgSName(Self),
' Old=',Left,',',Top,',',Width,',',Height,
' New=',ALeft,',',ATop,',',AWidth,',',AHeight,
' KeepBase=',KeepBase]);
//if (Parent=nil) and (Left>0) and (ALeft=0) then DumpStack; // This can happen if the interface has not yet moved the window and for some reason something applies the interface coords back to the LCL
{$ENDIF}
if not KeepBase then UpdateAlignIndex;
// constraint the size
DoConstrainedResize(ALeft, ATop, AWidth, AHeight);
// check, if we are already processing this bound change
NewBounds := Bounds(ALeft, ATop, AWidth, AHeight);
if CompareRect(@FLastChangebounds, @NewBounds) then Exit;
FLastChangebounds := NewBounds;
OldLeft := FLeft;
OldTop := FTop;
OldWidth := FWidth;
OldHeight := FHeight;
// check if something would change
SizeChanged := (FWidth <> AWidth) or (FHeight <> AHeight);
PosChanged := (FLeft <> ALeft) or (FTop <> ATop);
if (not SizeChanged) and (not PosChanged) then Exit;
//DebugLn('TControl.ChangeBounds A ',DbgSName(Self),' Old=',dbgs(BoundsRect),' New=',dbgs(NewBounds));
if (not (csLoading in ComponentState))
and (not (Self is TWinControl)) then
InvalidateControl(IsControlVisible, False, true);
//DebugLn('TControl.ChangeBounds B ',Name,':',ClassName);
DoSetBounds(ALeft, ATop, AWidth, AHeight);
// change base bounds
// (base bounds are the base for the automatic resizing)
if not KeepBase then
UpdateAnchorRules;
// lock size messages
inc(FSizeLock);
try
// notify before autosizing
BoundsChanged;
if PosSizeKept then exit;
if (Parent<>nil) or SizeChanged then
AdjustSize;
finally
dec(FSizeLock);
end;
if PosSizeKept then exit;
// send messages, if this is the top level call
if FSizeLock > 0 then exit;
// invalidate
if (csDesigning in ComponentState) and (Parent <> nil) then
Parent.Invalidate
else
if (not (csLoading in ComponentState)) and (not (Self is TWinControl)) then
Invalidate;
// notify user about resize
if (not (csLoading in ComponentState)) then
begin
Resize;
CheckOnChangeBounds;
// for delphi compatibility send size/move messages
PosSizeKept;
SendMoveSizeMessages(SizeChanged,PosChanged);
end;
end;
{-------------------------------------------------------------------------------
TControl.DoSetBounds
Params: ALeft, ATop, AWidth, AHeight : integer
store bounds in private variables
-------------------------------------------------------------------------------}
procedure TControl.DoSetBounds(ALeft, ATop, AWidth, AHeight : integer);
procedure BoundsOutOfBounds;
begin
DebugLn('TControl.DoSetBounds ',Name,':',ClassName,
' Old=',dbgs(Left,Top,Width,Height),
' New=',dbgs(aLeft,aTop,aWidth,aHeight),
'');
RaiseGDBException('TControl.DoSetBounds '+Name+':'+ClassName+' Invalid bounds');
end;
begin
if (AWidth>100000) or (AHeight>100000) then
BoundsOutOfBounds;
{$IFDEF CHECK_POSITION}
if CheckPosition(Self) then
DebugLn(['TControl.DoSetBounds ',DbgSName(Self),
' Old=',Left,',',Top,',',Width,'x',Height,
' New=',aLeft,',',aTop,',',aWidth,'x',aHeight]);
{$ENDIF}
FLeft := ALeft;
FTop := ATop;
FWidth := AWidth;
FHeight := AHeight;
if Parent <> nil then Parent.InvalidatePreferredSize;
end;
{------------------------------------------------------------------------------
TControl.ChangeScale
Scale contorl by factor Multiplier/Divider
------------------------------------------------------------------------------}
procedure TControl.ChangeScale(Multiplier, Divider: Integer);
begin
// TODO: TCONTROL.CHANGESCALE
//Assert(False, 'Trace:TODO: [TControl.ChangeScale]');
end;
{------------------------------------------------------------------------------
procedure TControl.CalculateDockSizes;
Compute docking width, height based on docking properties.
------------------------------------------------------------------------------}
procedure TControl.CalculateDockSizes;
begin
if Floating then
begin
// if control is floating then save it size for further undocking
UndockHeight := Height;
UndockWidth := Width;
end
else
if HostDockSite <> nil then
begin
// the control is docked into a HostSite. That means some of it bounds
// were maximized to fit into the HostSite.
if (DockOrientation = doHorizontal) or
(HostDockSite.Align in [alLeft,alRight]) then
// the control is aligned left/right, that means its width is not
// maximized. Save Width for docking.
LRDockWidth := Width
else
if (DockOrientation = doVertical) or
(HostDockSite.Align in [alTop,alBottom]) then
// the control is aligned top/bottom, that means its height is not
// maximized. Save Height for docking.
TBDockHeight := Height;
end;
end;
{------------------------------------------------------------------------------
function TControl.CreateFloatingDockSite(const Bounds: TRect): TWinControl;
------------------------------------------------------------------------------}
function TControl.CreateFloatingDockSite(const Bounds: TRect): TWinControl;
var
FloatingClass: TWinControlClass;
NewWidth: Integer;
NewHeight: Integer;
NewClientWidth: Integer;
NewClientHeight: Integer;
begin
Result := nil;
FloatingClass:=FloatingDockSiteClass;
if (FloatingClass<>nil) and (FloatingClass<>TWinControlClass(ClassType)) then
begin
Result := TWinControl(FloatingClass.NewInstance);
Result.DisableAutoSizing;
Result.Create(Self);
// resize with minimal resizes
NewClientWidth:=Bounds.Right-Bounds.Left;
NewClientHeight:=Bounds.Bottom-Bounds.Top;
NewWidth:=Result.Width-Result.ClientWidth+NewClientWidth;
NewHeight:=Result.Height-Result.ClientHeight+NewClientHeight;
Result.SetBounds(Bounds.Left,Bounds.Top,NewWidth,NewHeight);
Result.SetClientSize(Point(NewClientWidth,NewClientHeight));
debugln('TControl.CreateFloatingDockSite A ',DbgSName(Self),' ',DbgSName(Result),' ',dbgs(Result.BoundsRect));
Result.EnableAutoSizing;
end;
end;
procedure TControl.ExecuteDefaultAction;
begin
end;
procedure TControl.ExecuteCancelAction;
begin
end;
{------------------------------------------------------------------------------
function TControl.GetFloating: Boolean;
------------------------------------------------------------------------------}
function TControl.GetFloating: Boolean;
begin
// a non-windowed control can never float for itself
Result := (HostDockSite <> nil) and (HostDockSite is FloatingDockSiteClass)
and (HostDockSite.DockClientCount<=1);
end;
{------------------------------------------------------------------------------
function TControl.GetFloatingDockSiteClass: TWinControlClass;
------------------------------------------------------------------------------}
function TControl.GetFloatingDockSiteClass: TWinControlClass;
begin
Result := FFloatingDockSiteClass;
end;
{------------------------------------------------------------------------------
function TControl.GetLRDockWidth: Integer;
------------------------------------------------------------------------------}
function TControl.GetLRDockWidth: Integer;
begin
if FLRDockWidth>0 then
Result := FLRDockWidth
else
Result := UndockWidth;
end;
{------------------------------------------------------------------------------
function TControl.IsHelpContextStored: boolean;
------------------------------------------------------------------------------}
function TControl.IsHelpContextStored: boolean;
begin
Result := (ActionLink = nil) or not ActionLink.IsHelpLinked;
end;
{------------------------------------------------------------------------------
function TControl.IsHelpKeyWordStored: boolean;
------------------------------------------------------------------------------}
// Using IsHelpContextLinked() for controlling HelpKeyword
// is not correct. Therefore, use IsHelpLinked which means that all 3 Help* properties
// must be equal. Also, this function becomes exactly the same as one just above.
function TControl.IsHelpKeyWordStored: boolean;
begin
Result := (ActionLink = nil) or not ActionLink.IsHelpLinked;
end;
function TControl.IsOnClickStored: Boolean;
begin
Result := (ActionLink = nil) or not ActionLink.IsOnExecuteLinked;
end;
function TControl.IsShowHintStored: Boolean;
begin
Result := not ParentShowHint;
end;
function TControl.IsVisibleStored: Boolean;
begin
Result := (ActionLink = nil) or not ActionLink.IsVisibleLinked;
end;
function TControl.GetUndockHeight: Integer;
begin
if FUndockHeight > 0 then
Result := FUndockHeight
else
Result := Height;
end;
function TControl.GetUndockWidth: Integer;
begin
if FUndockWidth > 0 then
Result := FUndockWidth
else
Result := Width;
end;
function TControl.IsAnchorsStored: boolean;
begin
Result:=(Anchors<>AnchorAlign[Align]);
end;
function TControl.IsVisible: Boolean;
begin
Result := IsControlVisible and ((Parent = nil) or (Parent.IsVisible));
end;
function TControl.IsControlVisible: Boolean;
begin
Result := (FVisible
or ((csDesigning in ComponentState)
and (not (csNoDesignVisible in ControlStyle))));
end;
function TControl.FormIsUpdating: boolean;
begin
Result := Assigned(Parent) and Parent.FormIsUpdating;
end;
function TControl.IsProcessingPaintMsg: boolean;
begin
Result:=cfProcessingWMPaint in FControlFlags;
end;
{------------------------------------------------------------------------------
TControl.LMCaptureChanged
------------------------------------------------------------------------------}
procedure TControl.LMCaptureChanged(Var Message: TLMessage);
begin
//DebugLn('[LMCaptureChanged for '+Name+':'+Classname+']');
CaptureChanged;
end;
{------------------------------------------------------------------------------
TControl.CMENABLEDCHANGED
------------------------------------------------------------------------------}
procedure TControl.CMEnabledChanged(var Message: TLMEssage);
begin
Invalidate;
end;
{------------------------------------------------------------------------------
TControl.CMHITTEST
------------------------------------------------------------------------------}
procedure TControl.CMHITTEST(var Message : TCMHitTest);
begin
Message.Result := 1;
end;
{------------------------------------------------------------------------------
TControl.CMMouseEnter
------------------------------------------------------------------------------}
procedure TControl.CMMouseEnter(var Message: TLMessage);
begin
// this is a LCL based mouse message, so don't call DoBeforeMouseMessage
//DebugLn('TControl.CMMouseEnter ',Name,':',ClassName,' ',FMouseEntered,' ',Message.LParam);
if (Message.LParam=0) and (not FMouseEntered) then
begin
FMouseEntered := True;
MouseEnter;
if FParent <> nil then
FParent.Perform(CM_MOUSEENTER, 0, LParam(Self));
end;
end;
{------------------------------------------------------------------------------
TControl.CMMouseLeave
------------------------------------------------------------------------------}
procedure TControl.CMMouseLeave(var Message: TLMessage);
begin
// this is a LCL based mouse message, so don't call DoBeforeMouseMessage
//DebugLn('TControl.CMMouseLeave ',Name,':',ClassName,' ',FMouseEntered,' ',Message.LParam);
if (Message.LParam = 0) and FMouseEntered then
begin
FMouseEntered := False;
MouseLeave;
if FParent <> nil then
FParent.Perform(CM_MOUSELEAVE, 0, LParam(Self));
end;
end;
{------------------------------------------------------------------------------
procedure TControl.CMHintShow(var Message: TLMessage);
------------------------------------------------------------------------------}
procedure TControl.CMHintShow(var Message: TLMessage);
begin
DoOnShowHint(TCMHintShow(Message).HintInfo);
if (ActionLink <> nil)
and not ActionLink.DoShowHint(TCMHintShow(Message).HintInfo^.HintStr)
then
Message.Result := 1;
end;
{------------------------------------------------------------------------------
TControl.CMVisibleChanged
------------------------------------------------------------------------------}
procedure TControl.CMVisibleChanged(var Message : TLMessage);
begin
if (not (csDesigning in ComponentState) or (csNoDesignVisible in ControlStyle)) and
(not (csLoading in ComponentState)) then
InvalidateControl(True, FVisible and (csOpaque in ControlStyle), True);
end;
procedure TControl.CMTextChanged(var Message: TLMessage);
begin
TextChanged;
end;
procedure TControl.CMWantSpecialKey(var Message: TLMessage);
begin
// by default control does not want to handle VK_TAB itself
if Message.wParam = VK_TAB then
Message.Result := 0
else
Message.Result := 1;
end;
{------------------------------------------------------------------------------
TControl.CMParentColorChanged
assumes: FParent <> nil
------------------------------------------------------------------------------}
procedure TControl.CMParentColorChanged(var Message: TLMessage);
begin
if csLoading in ComponentState then Exit;
if FParentColor then
begin
Color := FParent.Color;
FParentColor := True;
end;
end;
{------------------------------------------------------------------------------
TControl.CMParentFontChanged
assumes: FParent <> nil
------------------------------------------------------------------------------}
procedure TControl.CMParentFontChanged(var Message: TLMessage);
begin
if csLoading in ComponentState then exit;
if FParentFont then
begin
Font := FParent.Font;
FParentFont := True;
end;
//call here for compatibility with older LCL code
ParentFontChanged;
end;
{------------------------------------------------------------------------------
TControl.CMShowHintChanged
assumes: FParent <> nil
------------------------------------------------------------------------------}
procedure TControl.CMParentShowHintChanged(var Message: TLMessage);
begin
if csLoading in ComponentState then Exit;
if FParentShowHint then
begin
ShowHint := FParent.ShowHint;
FParentShowHint := True;
end;
end;
{------------------------------------------------------------------------------}
{ TControl.ConstrainedResize }
{------------------------------------------------------------------------------}
procedure TControl.ConstrainedResize(var MinWidth, MinHeight,
MaxWidth, MaxHeight : TConstraintSize);
begin
if Assigned(FOnConstrainedResize) then
FOnConstrainedResize(Self, MinWidth, MinHeight, MaxWidth, MaxHeight);
end;
{------------------------------------------------------------------------------
procedure TControl.CalculatePreferredSize(var PreferredWidth,
PreferredHeight: integer; WithThemeSpace: Boolean);
Calculates the default/preferred width and height for a control, which is used
by the LCL autosizing algorithms as default size. Only positive values are
valid. Negative or 0 are treated as undefined and the LCL uses other sizes
instead.
TWinControl overrides this and asks the interface for theme dependent values.
See TWinControl.GetPreferredSize for more information.
WithThemeSpace: If true, adds space for stacking. For example: TRadioButton
has a minimum size. But for staking multiple TRadioButtons there should be
some space around. This space is theme dependent, so it passed parameter to
the widgetset.
------------------------------------------------------------------------------}
procedure TControl.CalculatePreferredSize(var PreferredWidth,
PreferredHeight: integer; WithThemeSpace: Boolean);
begin
PreferredWidth:=0;
PreferredHeight:=0;
end;
{------------------------------------------------------------------------------
function TControl.GetPalette: HPalette;
------------------------------------------------------------------------------}
function TControl.GetPalette: HPalette;
begin
Result:=0;
end;
function TControl.ChildClassAllowed(ChildClass: TClass): boolean;
begin
Result:=false;
end;
{------------------------------------------------------------------------------
procedure TControl.DoOnResize;
Call events
------------------------------------------------------------------------------}
procedure TControl.DoOnResize;
begin
if Assigned(FOnResize) then FOnResize(Self);
DoCallNotifyHandler(chtOnResize);
end;
{------------------------------------------------------------------------------
procedure TControl.DoOnChangeBounds;
Call events
------------------------------------------------------------------------------}
procedure TControl.DoOnChangeBounds;
begin
Exclude(FControlFlags,cfOnChangeBoundsNeeded);
if Assigned(FOnChangeBounds) then FOnChangeBounds(Self);
DoCallNotifyHandler(chtOnChangeBounds);
end;
procedure TControl.CheckOnChangeBounds;
var
CurBounds: TRect;
CurClientSize: TPoint;
begin
if [csLoading,csDestroying]*ComponentState<>[] then exit;
CurBounds:=BoundsRect;
CurClientSize:=Point(ClientWidth,ClientHeight);
if (not CompareRect(@FLastDoChangeBounds,@CurBounds))
or (ComparePoints(CurClientSize,FLastDoChangeClientSize)<>0) then begin
if FormIsUpdating then begin
Include(FControlFlags,cfOnChangeBoundsNeeded);
exit;
end;
FLastDoChangeBounds:=CurBounds;
FLastDoChangeClientSize:=CurClientSize;
DoOnChangeBounds;
end;
end;
{------------------------------------------------------------------------------
procedure TControl.DoBeforeMouseMessage;
------------------------------------------------------------------------------}
procedure TControl.DoBeforeMouseMessage;
begin
if Application<>nil then
Application.DoBeforeMouseMessage(Self);
end;
{------------------------------------------------------------------------------
function TControl.ColorIsStored: boolean;
------------------------------------------------------------------------------}
function TControl.ColorIsStored: boolean;
begin
Result := not ParentColor;
end;
{------------------------------------------------------------------------------
TControl.DoConstrainedResize
------------------------------------------------------------------------------}
procedure TControl.DoConstrainedResize(var NewLeft, NewTop,
NewWidth, NewHeight: integer);
var
MinWidth, MinHeight, MaxWidth, MaxHeight : TConstraintSize;
begin
MinWidth := Constraints.EffectiveMinWidth;
MinHeight := Constraints.EffectiveMinHeight;
MaxWidth := Constraints.EffectiveMaxWidth;
MaxHeight := Constraints.EffectiveMaxHeight;
ConstrainedResize(MinWidth, MinHeight, MaxWidth, MaxHeight);
if (MinWidth > 0) and (NewWidth < MinWidth) then
begin
// right kept position ? interpret as resizing left border
if (NewLeft+NewWidth) = (Left+Width) then
begin
Dec(NewLeft, MinWidth - NewWidth);
if NewLeft < Left then
NewLeft := Left;
end;
NewWidth := MinWidth
end else if (MaxWidth > 0) and (NewWidth > MaxWidth) then
begin
if (NewLeft+NewWidth) = (Left+Width) then
begin
Inc(NewLeft, NewWidth - MaxWidth);
if NewLeft > Left then
NewLeft := Left;
end;
NewWidth := MaxWidth;
end;
if (MinHeight > 0) and (NewHeight < MinHeight) then
begin
// bottom kept position ? interpret as resizing bottom border
if (NewTop+NewHeight) = (Top+Height) then
begin
Dec(NewTop, MinHeight - NewHeight);
if NewTop < Top then
NewTop := Top;
end;
NewHeight := MinHeight
end else if (MaxHeight > 0) and (NewHeight > MaxHeight) then
begin
if (NewTop+NewHeight) = (Top+Height) then
begin
Inc(NewTop, NewHeight - MaxHeight);
if NewTop > Top then
NewTop := Top;
end;
NewHeight := MaxHeight;
end;
//debugln('TControl.DoConstrainedResize ',DbgSName(Self),' ',dbgs(NewWidth),',',dbgs(NewHeight));
end;
{------------------------------------------------------------------------------
TControl.DoConstraintsChange
------------------------------------------------------------------------------}
procedure TControl.DoConstraintsChange(Sender : TObject);
begin
AdjustSize;
end;
procedure TControl.DoBorderSpacingChange(Sender: TObject;
InnerSpaceChanged: Boolean);
begin
if InnerSpaceChanged then
AdjustSize
else
RequestAlign;
if (csDesigning in ComponentState) and (Parent <> nil) then
Parent.Invalidate;
end;
function TControl.IsBorderSpacingInnerBorderStored: Boolean;
begin
Result:=BorderSpacing.InnerBorder<>0;
end;
{------------------------------------------------------------------------------
procedure TControl.SendMoveSizeMessages(SizeChanged, PosChanged: boolean);
------------------------------------------------------------------------------}
procedure TControl.SendMoveSizeMessages(SizeChanged, PosChanged: boolean);
begin
end;
{------------------------------------------------------------------------------
TControl.DragCanceled
------------------------------------------------------------------------------}
procedure TControl.DragCanceled;
begin
{$IFDEF VerboseDrag}
DebugLn('TControl.DragCanceled');
{$ENDIF}
end;
{------------------------------------------------------------------------------
TControl.DoStartDrag
------------------------------------------------------------------------------}
procedure TControl.DoStartDrag(var DragObject: TDragObject);
begin
{$IFDEF VerboseDrag}
DebugLn('TControl.DoStartDrag ',Name,':',ClassName);
{$ENDIF}
if Assigned(FOnStartDrag) then FOnStartDrag(Self, DragObject);
end;
{------------------------------------------------------------------------------
TControl.DoEndDrag
------------------------------------------------------------------------------}
procedure TControl.DoEndDrag(Target: TObject; X,Y: Integer);
begin
{$IFDEF VerboseDrag}
DebugLn('TControl.DoEndDrag ',Name,':',ClassName,' XY=',IntToStr(X),',',IntToStr(Y));
{$ENDIF}
if Assigned(FOnEndDrag) then FOnEndDrag(Self,Target,X,Y);
end;
{------------------------------------------------------------------------------
TControl.Perform
------------------------------------------------------------------------------}
function TControl.Perform(Msg:Cardinal; WParam: WParam; LParam: LParam): LRESULT;
var
Message : TLMessage;
begin
Message.Msg := Msg;
Message.WParam := WParam;
Message.LParam := LParam;
Message.Result := 0;
if Self <> nil then WindowProc(Message);
Result := Message.Result;
end;
{------------------------------------------------------------------------------
TControl.GetClientOrigin
------------------------------------------------------------------------------}
function TControl.GetClientOrigin: TPoint;
procedure RaiseParentNil;
begin
raise Exception.Create('TControl.GetClientOrigin: Parent=nil for '
+Name+':'+ClassName);
end;
begin
//Assert(False, Format('Trace:[TControl.GetClientOrigin] %s', [Classname]));
if Parent = nil then
RaiseParentNil;
//raise EInvalidOperation.CreateFmt(SParentRequired, [Name]);
Result := Parent.ClientOrigin;
Inc(Result.X, FLeft);
Inc(Result.Y, FTop);
//Assert(False, Format('Trace:[TControl.GetClientOrigin] %s --> (%d, %d)', [Classname, Result.X, Result.Y]));
end;
{------------------------------------------------------------------------------
TControl.ScreenToClient
------------------------------------------------------------------------------}
function TControl.ScreenToClient(const APoint: TPoint): TPoint;
var
P : TPoint;
begin
P := ClientOrigin;
Result.X := APoint.X - P.X;
Result.Y := APoint.Y - P.Y;
end;
{------------------------------------------------------------------------------
function TControl.ClientToScreen(const APoint: TPoint): TPoint;
------------------------------------------------------------------------------}
function TControl.ClientToScreen(const APoint: TPoint): TPoint;
var
P : TPoint;
begin
P := ClientOrigin;
Result.X := APoint.X + P.X;
Result.Y := APoint.Y + P.Y;
end;
{------------------------------------------------------------------------------
function TControl.ScreenToControl(const APoint: TPoint): TPoint;
------------------------------------------------------------------------------}
function TControl.ScreenToControl(const APoint: TPoint): TPoint;
var
P : TPoint;
begin
P := ControlOrigin;
Result.X := APoint.X - P.X;
Result.Y := APoint.Y - P.Y;
end;
{------------------------------------------------------------------------------
function TControl.ControlToScreen(const APoint: TPoint): TPoint;
------------------------------------------------------------------------------}
function TControl.ControlToScreen(const APoint: TPoint): TPoint;
var
P : TPoint;
begin
P := ControlOrigin;
Result.X := APoint.X + P.X;
Result.Y := APoint.Y + P.Y;
end;
{------------------------------------------------------------------------------
TControl.DblClick
------------------------------------------------------------------------------}
procedure TControl.DblClick;
begin
If Assigned(FOnDblClick) then FOnDblClick(Self);
end;
{------------------------------------------------------------------------------
TControl.TripleClick
------------------------------------------------------------------------------}
procedure TControl.TripleClick;
begin
If Assigned(FOnTripleClick) then FOnTripleClick(Self);
end;
{------------------------------------------------------------------------------
TControl.QuadClick
------------------------------------------------------------------------------}
procedure TControl.QuadClick;
begin
If Assigned(FOnQuadClick) then FOnQuadClick(Self);
end;
{------------------------------------------------------------------------------
TControl.DoDragMsg
------------------------------------------------------------------------------}
function TControl.DoDragMsg(ADragMessage: TDragMessage; APosition: TPoint;
ADragObject: TDragObject; ATarget: TControl; ADocking: Boolean): LRESULT;
function GetDragObject: TObject; inline;
begin
if ADragObject.AutoCreated then
Result := ADragObject.Control
else
Result := ADragObject;
end;
var
AWinTarget: TWinControl;
Accepts: Boolean;
P: TPoint;
begin
Result := 0;
{$IFDEF VerboseDrag}
DebugLn('TControl.DoDragMsg ',Name,':',ClassName,' DragMsg.DragMessage=', GetEnumName(TypeInfo(TDragMessage), Ord(ADragMessage)));
{$ENDIF}
case ADragMessage of
dmFindTarget:
Result := PtrInt(Self);
dmDragEnter, dmDragLeave, dmDragMove:
begin
Accepts := True;
P := ScreenToClient(APosition);
if ADragObject is TDragDockObject then
begin
AWinTarget:= TWinControl(ADragObject.DragTarget);
AWinTarget.DockOver(TDragDockObject(ADragObject), P.X, P.Y, TDragState(ADragMessage), Accepts);
end
else
DragOver(GetDragObject, P.X, P.Y, TDragState(ADragMessage), Accepts);
Result := Ord(Accepts);
end;
dmDragDrop:
begin
P := ScreenToClient(APosition);
if ADragObject is TDragDockObject then
begin
AWinTarget:= TWinControl(ADragObject.DragTarget);
AWinTarget.DockDrop(TDragDockObject(ADragObject), P.X, P.Y);
end
else
DragDrop(GetDragObject, P.X, P.Y);
end;
end;
end;
{------------------------------------------------------------------------------
TControl.DragOver
------------------------------------------------------------------------------}
procedure TControl.DragOver(Source: TObject; X,Y : Integer; State: TDragState;
var Accept:Boolean);
begin
{$IFDEF VerboseDrag}
DebugLn('TControl.DragOver ',Name,':',ClassName,' XY=',IntToStr(X),',',IntToStr(Y));
{$ENDIF}
Accept := False;
if Assigned(FOnDragOver) then begin
Accept := True;
FOnDragOver(Self,Source,X,Y,State,Accept);
end;
end;
{------------------------------------------------------------------------------
TControl.DragDrop
------------------------------------------------------------------------------}
procedure TControl.DragDrop(Source: TObject; X,Y : Integer);
begin
{$IFDEF VerboseDrag}
DebugLn('TControl.DragDrop ',Name,':',ClassName,' XY=',IntToStr(X),',',IntToStr(Y));
{$ENDIF}
If Assigned(FOnDragDrop) then FOnDragDrop(Self, Source,X,Y);
end;
{------------------------------------------------------------------------------
TControl Method SetColor "Sets the default color and tells the widget set"
------------------------------------------------------------------------------}
procedure TControl.SetColor(value : TColor);
begin
if FColor <> Value then
begin
FColor := Value;
FParentColor := False;
Invalidate;
end;
end;
{------------------------------------------------------------------------------
TControl CanAutoSize
------------------------------------------------------------------------------}
function TControl.CanAutoSize(Var NewWidth, NewHeight : Integer): Boolean;
begin
Result := True;
end;
{------------------------------------------------------------------------------
TControl UpdateAlignIndex
Move this control to position 0 of Parent.FAlignOrder
------------------------------------------------------------------------------}
procedure TControl.UpdateAlignIndex;
var
i: Integer;
begin
if Parent=nil then exit;
if Parent.FAlignOrder=nil then
Parent.FAlignOrder:=TFPList.Create;
i:=Parent.FAlignOrder.IndexOf(Self);
if i<0 then
Parent.FAlignOrder.Insert(0,Self)
else
Parent.FAlignOrder.Move(i,0);
end;
{------------------------------------------------------------------------------
TControl Dragging
------------------------------------------------------------------------------}
function TControl.Dragging: Boolean;
begin
Result := DragManager.Dragging(Self);
end;
{------------------------------------------------------------------------------
TControl GetBoundsRect
------------------------------------------------------------------------------}
function TControl.GetBoundsRect: TRect;
begin
Result.Left := FLeft;
Result.Top := FTop;
Result.Right := FLeft+FWidth;
Result.Bottom := FTop+FHeight;
end;
function TControl.GetClientHeight: Integer;
begin
Result:=ClientRect.Bottom;
end;
function TControl.GetClientWidth: Integer;
begin
Result:=ClientRect.Right;
end;
{------------------------------------------------------------------------------
TControl GetEnabled
------------------------------------------------------------------------------}
function TControl.GetEnabled: Boolean;
begin
Result := FEnabled;
end;
{------------------------------------------------------------------------------
TControl GetMouseCapture
------------------------------------------------------------------------------}
function TControl.GetMouseCapture : Boolean;
begin
Result := GetCaptureControl = Self;
end;
function TControl.GetTBDockHeight: Integer;
begin
if FTBDockHeight>0 then
Result := FTBDockHeight
else
Result := UndockHeight;
end;
{------------------------------------------------------------------------------
TControl GetPopupMenu
------------------------------------------------------------------------------}
function TControl.GetPopupMenu: TPopupMenu;
begin
Result := FPopupMenu;
end;
{------------------------------------------------------------------------------
procedure TControl.DoOnShowHint(HintInfo: Pointer);
------------------------------------------------------------------------------}
procedure TControl.DoOnShowHint(HintInfo: PHintInfo);
begin
if Assigned(OnShowHint) then
OnShowHint(Self,HintInfo);
end;
function TControl.IsAParentAligning: boolean;
var
p: TWinControl;
begin
p:=Parent;
while (p<>nil) do begin
if (wcfAligningControls in p.FWinControlFlags) then
exit(true);
p:=p.Parent;
end;
Result:=false;
end;
{------------------------------------------------------------------------------
procedure TControl.VisibleChanging;
------------------------------------------------------------------------------}
procedure TControl.VisibleChanging;
begin
DoCallNotifyHandler(chtOnVisibleChanging);
end;
procedure TControl.VisibleChanged;
begin
{ TODO -cdocking : For docked controls, the docking manager must receive a notification!
}
DoCallNotifyHandler(chtOnVisibleChanged);
end;
procedure TControl.AddHandler(HandlerType: TControlHandlerType;
const AMethod: TMethod; AsFirst: boolean);
begin
if FControlHandlers[HandlerType]=nil then
FControlHandlers[HandlerType]:=TMethodList.Create;
FControlHandlers[HandlerType].Add(AMethod);
end;
procedure TControl.RemoveHandler(HandlerType: TControlHandlerType;
const AMethod: TMethod);
begin
FControlHandlers[HandlerType].Remove(AMethod);
end;
procedure TControl.DoCallNotifyHandler(HandlerType: TControlHandlerType);
begin
FControlHandlers[HandlerType].CallNotifyEvents(Self);
end;
{------------------------------------------------------------------------------
procedure TControl.DoContextPopup(const MousePos: TPoint;
var Handled: Boolean);
------------------------------------------------------------------------------}
procedure TControl.DoContextPopup(const MousePos: TPoint; var Handled: Boolean);
begin
if Assigned(FOnContextPopup) then
FOnContextPopup(Self, MousePos, Handled);
end;
procedure TControl.ActionChange(Sender: TObject; CheckDefaults: Boolean);
var
NewAction: TCustomAction;
begin
if Sender is TCustomAction then begin
NewAction:=TCustomAction(Sender);
if (not CheckDefaults)
or (Caption = '') or (Caption = Name) then
Caption := NewAction.Caption;
if not CheckDefaults or Enabled then
Enabled := NewAction.Enabled;
if not CheckDefaults or (Hint = '') then
Hint := NewAction.Hint;
if not CheckDefaults or Visible then
Visible := NewAction.Visible;
if not CheckDefaults or not Assigned(OnClick) then
OnClick := NewAction.OnExecute;
if not CheckDefaults or (Self.HelpContext = 0) then
Self.HelpContext := HelpContext;
if not CheckDefaults or (Self.HelpKeyword = '') then
Self.HelpKeyword := HelpKeyword;
// HelpType is set implicitly when assigning HelpContext or HelpKeyword
end;
end;
procedure TControl.DoActionChange(Sender: TObject);
begin
if Sender = Action then ActionChange(Sender, False);
end;
function TControl.CaptureMouseButtonsIsStored: boolean;
begin
Result := FCaptureMouseButtons <> [mbLeft];
end;
function TControl.GetAnchorSide(Kind: TAnchorKind): TAnchorSide;
begin
Result:=FAnchorSides[Kind];
end;
function TControl.GetAnchorSideIndex(Index: integer): TAnchorSide;
begin
case Index of
0: Result:=FAnchorSides[akLeft];
1: Result:=FAnchorSides[akTop];
2: Result:=FAnchorSides[akRight];
3: Result:=FAnchorSides[akBottom];
else
Result:=nil;
end;
end;
function TControl.GetAnchoredControls(Index: integer): TControl;
begin
Result := TControl(FAnchoredControls[Index]);
end;
function TControl.GetAutoSizingAll: Boolean;
begin
if Parent <> nil then
Result := Parent.AutoSizingAll
else
Result := FAutoSizingAll;
end;
{------------------------------------------------------------------------------
TControl GetClientRect
Returns the size of visual client area.
For example the inner size of a TGroupBox.
For a TScrollBox it is the visual size, not the logical size.
------------------------------------------------------------------------------}
function TControl.GetClientRect: TRect;
begin
Result.Left := 0;
Result.Top := 0;
Result.Right := Width;
Result.Bottom := Height;
end;
{------------------------------------------------------------------------------
TControl GetLogicalClientRect
Returns the size of complete client area. It can be bigger or smaller than
the visual size, but normally it is the same. For example a TScrollBox can
have different sizes.
------------------------------------------------------------------------------}
function TControl.GetLogicalClientRect: TRect;
begin
Result:=ClientRect;
end;
{------------------------------------------------------------------------------
function TControl.GetScrolledClientRect: TRect;
------------------------------------------------------------------------------}
function TControl.GetScrolledClientRect: TRect;
var
ScrolledOffset: TPoint;
begin
Result:=GetClientRect;
ScrolledOffset:=GetClientScrollOffset;
inc(Result.Left,ScrolledOffset.X);
inc(Result.Top,ScrolledOffset.Y);
inc(Result.Right,ScrolledOffset.X);
inc(Result.Bottom,ScrolledOffset.Y);
end;
{------------------------------------------------------------------------------
function TControl.GetChildsRect(Scrolled: boolean): TRect;
Returns the Client rectangle relative to the controls left, top.
If Scrolled is true, the rectangle is moved by the current scrolling values
(for an example see TScrollingWincontrol).
------------------------------------------------------------------------------}
function TControl.GetChildsRect(Scrolled: boolean): TRect;
var
ScrolledOffset: TPoint;
begin
Result:=ClientRect;
if Scrolled then begin
ScrolledOffset:=GetClientScrollOffset;
inc(Result.Left,ScrolledOffset.X);
inc(Result.Top,ScrolledOffset.Y);
inc(Result.Right,ScrolledOffset.X);
inc(Result.Bottom,ScrolledOffset.Y);
end;
end;
{------------------------------------------------------------------------------
function TControl.GetClientScrollOffset: TPoint;
Returns the scrolling offset of the client area.
------------------------------------------------------------------------------}
function TControl.GetClientScrollOffset: TPoint;
begin
Result:=Point(0,0);
end;
{------------------------------------------------------------------------------
function TControl.GetControlOrigin: TPoint;
Returns the screen coordinate of the topleft pixel of the control.
------------------------------------------------------------------------------}
function TControl.GetControlOrigin: TPoint;
var
ParentsClientOrigin: TPoint;
begin
Result:=Point(Left,Top);
if Parent<>nil then begin
ParentsClientOrigin:=Parent.ClientOrigin;
inc(Result.X,ParentsClientOrigin.X);
inc(Result.Y,ParentsClientOrigin.Y);
end;
end;
{------------------------------------------------------------------------------
TControl WndPRoc
------------------------------------------------------------------------------}
procedure TControl.WndProc(var TheMessage : TLMessage);
var
Form : TCustomForm;
begin
//DebugLn('CCC TControl.WndPRoc ',Name,':',ClassName);
if (csDesigning in ComponentState) then
begin
// redirect messages to designer
Form := GetParentForm(Self);
//debugln(['TControl.WndProc ',dbgsname(Self)]);
if (Form <> nil) and (Form.Designer <> nil)
and Form.Designer.IsDesignMsg(Self,TheMessage) then begin
Exit;
end;
end
else if (TheMessage.Msg >= LM_KEYFIRST) and (TheMessage.Msg <= LM_KEYLAST)
then begin
// keyboard messages
Form := GetParentForm(Self);
if (Form <> nil) and (Form.WantChildKey(Self,TheMessage)) then exit;
end
else if ((TheMessage.Msg>=LM_MOUSEFIRST) and (TheMessage.Msg<=LM_MOUSELAST))
or ((TheMessage.Msg>=LM_MOUSEFIRST2) and (TheMessage.Msg<=LM_MOUSELAST2))
then begin
// mouse messages
// map double clicks for controls, that do not want doubleclicks
if not (csDoubleClicks in ControlStyle) then
begin
case TheMessage.Msg of
LM_LButtonDBLCLK,
LM_RButtonDBLCLK,
LM_MButtonDBLCLK:
Dec(TheMessage.Msg, LM_LBUTTONDBLCLK - LM_LBUTTONDOWN);
end;
end;
// map triple clicks for controls, that do not want tripleclicks
if not (csTripleClicks in ControlStyle) then
begin
case TheMessage.Msg of
LM_LBUTTONTRIPLECLK: TheMessage.Msg:=LM_LBUTTONDOWN;
LM_MBUTTONTRIPLECLK: TheMessage.Msg:=LM_MBUTTONDOWN;
LM_RBUTTONTRIPLECLK: TheMessage.Msg:=LM_RBUTTONDOWN;
end;
end;
// map quad clicks for controls, that do not want quadclicks
if not (csQuadClicks in ControlStyle) then
begin
case TheMessage.Msg of
LM_LBUTTONQUADCLK: TheMessage.Msg:=LM_LBUTTONDOWN;
LM_MBUTTONQUADCLK: TheMessage.Msg:=LM_MBUTTONDOWN;
LM_RBUTTONQUADCLK: TheMessage.Msg:=LM_RBUTTONDOWN;
end;
end;
case TheMessage.Msg of
LM_MOUSEMOVE:
begin
Application.HintMouseMessage(Self, TheMessage);
end;
LM_LBUTTONDOWN,
LM_LBUTTONDBLCLK:
begin
if FDragMode = dmAutomatic
then begin
BeginAutoDrag;
{ The VCL holds up the mouse down for dmAutomatic
and sends it, when it decides, if it is a drag operation or
not.
This decision requires full control of focus and mouse, which
do not all LCL interfaces provide. Therefore the mouse down event
is sent immediately.
Further Note:
Under winapi a LM_LBUTTONDOWN ends the drag immediate.
For example: If we exit here, then mouse down on TTreeView does
not work any longer under gtk.
}
// VCL: exit;
end;
Include(FControlState,csLButtonDown);
end;
LM_LBUTTONUP:
begin
Exclude(FControlState, csLButtonDown);
end;
end;
end;
//debugln(['TControl.WndProc ',DbgSName(Self),' ',TheMessage.Msg]);
if TheMessage.Msg=LM_PAINT then begin
Include(FControlFlags,cfProcessingWMPaint);
try
Dispatch(TheMessage);
finally
Exclude(FControlFlags,cfProcessingWMPaint);
end;
end else
Dispatch(TheMessage);
end;
{------------------------------------------------------------------------------
procedure TControl.ParentFormHandleInitialized;
called by ChildHandlesCreated of parent form
------------------------------------------------------------------------------}
procedure TControl.ParentFormHandleInitialized;
begin
// The form is really connection to the target screen. For example, the gtk
// under X gathers some screen information not before form creation.
// But this information is needed to create DeviceContexts, which
// are needed to calculate Text Size and such stuff needed for AutoSizing.
// That's why AdjustSize delays AutoSizing till this moment. Now do the
// AutoSize.
AdjustSize;
end;
{------------------------------------------------------------------------------
TControl Invalidate
------------------------------------------------------------------------------}
procedure TControl.Invalidate;
begin
//DebugLn(['TControl.Invalidate ',DbgSName(Self)]);
InvalidateControl(IsVisible, csOpaque in ControlStyle);
end;
{------------------------------------------------------------------------------
TControl DoMouseDown "Event Handler"
------------------------------------------------------------------------------}
procedure TControl.DoMouseDown(var Message: TLMMouse; Button: TMouseButton;
Shift: TShiftState);
begin
//DebugLn('TControl.DoMouseDown ',DbgSName(Self),' ');
if not (csNoStdEvents in ControlStyle) then begin
with Message do
MouseDown(Button, KeysToShiftState(Keys) + Shift, XPos, YPos);
end;
end;
{------------------------------------------------------------------------------
TControl DoMouseUp "Event Handler"
------------------------------------------------------------------------------}
procedure TControl.DoMouseUp(var Message: TLMMouse; Button: TMouseButton);
var
P: TPoint;
begin
if not (csNoStdEvents in ControlStyle) then
with Message do
begin
if (Button in [mbLeft, mbRight]) and DragManager.IsDragging then
begin
P := ClientToScreen(Point(XPos, YPos));
DragManager.MouseUp(Button, KeysToShiftState(Keys), P.X, P.Y);
Message.Result := 1;
end;
MouseUp(Button, KeysToShiftState(Keys), XPos, YPos);
end;
end;
{------------------------------------------------------------------------------
TControl DoMouseWheel "Event Handler"
------------------------------------------------------------------------------}
function TControl.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean;
begin
Result := False;
if Assigned(FOnMouseWheel)
then FOnMouseWheel(Self, Shift, WheelDelta, MousePos, Result);
if not Result
then begin
if WheelDelta < 0
then Result := DoMouseWheelDown(Shift, MousePos)
else Result := DoMouseWheelUp(Shift, MousePos);
end;
end;
{------------------------------------------------------------------------------
TControl DoMouseWheelDown "Event Handler"
------------------------------------------------------------------------------}
function TControl.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
Result := False;
if Assigned(FOnMouseWheelDown) then
FOnMouseWheelDown(Self, Shift, MousePos, Result);
end;
{------------------------------------------------------------------------------
TControl DoMouseWheelUp "Event Handler"
------------------------------------------------------------------------------}
function TControl.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
Result := False;
if Assigned(FOnMouseWheelUp) then
FOnMouseWheelUp(Self, Shift, MousePos, Result);
end;
procedure TControl.SetAnchorSideIndex(Index: integer; const AValue: TAnchorSide
);
begin
GetAnchorSideIndex(Index).Assign(AValue);
end;
procedure TControl.SetBorderSpacing(const AValue: TControlBorderSpacing);
begin
if FBorderSpacing=AValue then exit;
FBorderSpacing.Assign(AValue);
end;
{------------------------------------------------------------------------------
Method: TControl.WMContextMenu
Params: Message
Returns: Nothing
ContextMenu event handler
------------------------------------------------------------------------------}
procedure TControl.WMContextMenu(var Message: TLMContextMenu);
var
TempPopupMenu: TPopupMenu;
P: TPoint;
Handled: Boolean;
begin
if (csDesigning in ComponentState) or (Message.Result <> 0) then Exit;
P := SmallPointToPoint(Message.Pos);
// X and Y = -1 when user clicks on keyboard menu button
if P.X <> -1 then
P := ScreenToClient(P);
Handled := False;
DoContextPopup(P, Handled);
if Handled then
begin
Message.Result := 1;
Exit;
end;
TempPopupMenu := GetPopupMenu;
if (TempPopupMenu <> nil) then
begin
if not TempPopupMenu.AutoPopup then Exit;
TempPopupMenu.PopupComponent := Self;
if P.X = -1 then
P := Point(0, 0);
P := ClientToScreen(P);
TempPopupMenu.Popup(P.X, P.Y);
Message.Result := 1;
end;
end;
{------------------------------------------------------------------------------
Method: TControl.WMLButtonDown
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMLButtonDown(var Message: TLMLButtonDown);
begin
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (mbLeft in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMLButtonDown ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
if csClickEvents in ControlStyle then Include(FControlState, csClicked);
DoMouseDown(Message, mbLeft, []);
//DebugLn('TCONTROL WMLBUTTONDOWN B ',Name,':',ClassName);
end;
{------------------------------------------------------------------------------
Method: TControl.WMRButtonDown
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMRButtonDown(var Message: TLMRButtonDown);
begin
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (mbRight in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMRButtonDown ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
DoMouseDown(Message, mbRight, []);
end;
{------------------------------------------------------------------------------
Method: TControl.WMMButtonDown
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMMButtonDown(var Message: TLMMButtonDown);
begin
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (mbMiddle in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMMButtonDown ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
DoMouseDown(Message, mbMiddle, []);
end;
procedure TControl.WMXButtonDown(var Message: TLMXButtonDown);
var
Btn: TMouseButton;
begin
if (Message.Keys and MK_XBUTTON1) <> 0 then
Btn := mbExtra1
else
if (Message.Keys and MK_XBUTTON2) <> 0 then
Btn := mbExtra2
else
Exit;
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (Btn in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMXButtonDown ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
DoMouseDown(Message, Btn, []);
end;
{------------------------------------------------------------------------------
Method: TControl.WMLButtonDblClk
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMLButtonDblClk(var Message: TLMLButtonDblClk);
begin
DoBeforeMouseMessage;
//TODO: SendCancelMode(self);
if (csCaptureMouse in ControlStyle) and (mbLeft in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMLButtonDblClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
// first send a mouse down
DoMouseDown(Message, mbLeft ,[ssDouble]);
// then send the double click
if csClickEvents in ControlStyle then DblClick;
end;
{------------------------------------------------------------------------------
Method: TControl.WMRButtonDblClk
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMRButtonDblClk(var Message: TLMRButtonDblClk);
begin
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (mbRight in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMRButtonDblClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
DoMouseDown(Message, mbRight ,[ssDouble]);
end;
{------------------------------------------------------------------------------
Method: TControl.WMMButtonDblClk
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMMButtonDblClk(var Message: TLMMButtonDblClk);
begin
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (mbMiddle in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMMButtonDblClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
DoMouseDown(Message, mbMiddle ,[ssDouble]);
end;
procedure TControl.WMXButtonDBLCLK(var Message: TLMXButtonDblClk);
var
Btn: TMouseButton;
begin
if (Message.Keys and MK_XBUTTON1) <> 0 then
Btn := mbExtra1
else
if (Message.Keys and MK_XBUTTON2) <> 0 then
Btn := mbExtra2
else
Exit;
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (Btn in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMXButtonDblClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
DoMouseDown(Message, Btn, [ssDouble]);
end;
{------------------------------------------------------------------------------
Method: TControl.WMLButtonTripleClk
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMLButtonTripleClk(var Message: TLMLButtonTripleClk);
begin
DoBeforeMouseMessage;
//TODO: SendCancelMode(self);
if (csCaptureMouse in ControlStyle) and (mbLeft in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMLButtonTripleClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
if csClickEvents in ControlStyle then TripleClick;
DoMouseDown(Message, mbLeft ,[ssTriple]);
end;
{------------------------------------------------------------------------------
Method: TControl.WMRButtonTripleClk
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMRButtonTripleClk(var Message: TLMRButtonTripleClk);
begin
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (mbRight in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMRButtonTripleClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
DoMouseDown(Message, mbRight ,[ssTriple]);
end;
{------------------------------------------------------------------------------
Method: TControl.WMMButtonTripleClk
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMMButtonTripleClk(var Message: TLMMButtonTripleClk);
begin
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (mbMiddle in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMMButtonTripleClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
DoMouseDown(Message, mbMiddle ,[ssTriple]);
end;
procedure TControl.WMXButtonTripleCLK(var Message: TLMXButtonTripleClk);
var
Btn: TMouseButton;
begin
if (Message.Keys and MK_XBUTTON1) <> 0 then
Btn := mbExtra1
else
if (Message.Keys and MK_XBUTTON2) <> 0 then
Btn := mbExtra2
else
Exit;
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (Btn in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMXButtonTripleClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
DoMouseDown(Message, Btn, [ssTriple]);
end;
{------------------------------------------------------------------------------
Method: TControl.WMLButtonQuadClk
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMLButtonQuadClk(var Message: TLMLButtonQuadClk);
begin
DoBeforeMouseMessage;
//TODO: SendCancelMode(self);
if (csCaptureMouse in ControlStyle) and (mbLeft in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMLButtonQuadClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
if csClickEvents in ControlStyle then QuadClick;
DoMouseDown(Message, mbLeft ,[ssQuad]);
end;
{------------------------------------------------------------------------------
Method: TControl.WMRButtonQuadClk
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMRButtonQuadClk(var Message: TLMRButtonQuadClk);
begin
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (mbRight in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMRButtonQuadClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
DoMouseDown(Message, mbRight ,[ssQuad]);
end;
{------------------------------------------------------------------------------
Method: TControl.WMMButtonQuadClk
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMMButtonQuadClk(var Message: TLMMButtonQuadClk);
begin
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (mbMiddle in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMMButtonQuadClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
DoMouseDown(Message, mbMiddle ,[ssQuad]);
end;
procedure TControl.WMXButtonQuadCLK(var Message: TLMXButtonQuadClk);
var
Btn: TMouseButton;
begin
if (Message.Keys and MK_XBUTTON1) <> 0 then
Btn := mbExtra1
else
if (Message.Keys and MK_XBUTTON2) <> 0 then
Btn := mbExtra2
else
Exit;
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (Btn in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMMButtonQuadClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
DoMouseDown(Message, Btn, [ssQuad]);
end;
{------------------------------------------------------------------------------
Method: TControl.WMLButtonUp
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMLButtonUp(var Message: TLMLButtonUp);
begin
DoBeforeMouseMessage;
//DebugLn('TControl.WMLButtonUp A ',Name,':',ClassName,' csCaptureMouse=',DbgS(csCaptureMouse in ControlStyle),' csClicked=',DbgS(csClicked in ControlState));
if (csCaptureMouse in ControlStyle) and (mbLeft in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMLButtonUp ',Name,':',ClassName);
{$ENDIF}
MouseCapture := False;
end;
if csClicked in ControlState then
begin
Exclude(FControlState, csClicked);
//DebugLn('TControl.WMLButtonUp B ',dbgs(ClientRect.Left),',',dbgs(ClientRect.Top),',',dbgs(ClientRect.Right),',',dbgs(ClientRect.Bottom),' ',dbgs(Message.Pos.X),',',dbgs(Message.Pos.Y));
if PtInRect(ClientRect, SmallPointToPoint(Message.Pos))
then begin
//DebugLn('TControl.WMLButtonUp C');
Click;
end;
end;
DoMouseUp(Message, mbLeft);
//DebugLn('TControl.WMLButtonUp END');
end;
{------------------------------------------------------------------------------
Method: TControl.WMRButtonUp
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMRButtonUp(var Message: TLMRButtonUp);
begin
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (mbRight in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMRButtonUp ',Name,':',ClassName);
{$ENDIF}
MouseCapture := False;
end;
//MouseUp event is independent of return values of contextmenu
DoMouseUp(Message, mbRight);
end;
{------------------------------------------------------------------------------
Method: TControl.WMMButtonUp
Params: Message
Returns: Nothing
Mouse event handler
------------------------------------------------------------------------------}
procedure TControl.WMMButtonUp(var Message: TLMMButtonUp);
begin
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (mbMiddle in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMMButtonUp ',Name,':',ClassName);
{$ENDIF}
MouseCapture := False;
end;
DoMouseUp(Message, mbMiddle);
end;
procedure TControl.WMXButtonUp(var Message: TLMXButtonUp);
var
Btn: TMouseButton;
begin
if (Message.Keys and MK_XBUTTON1) <> 0 then
Btn := mbExtra1
else
if (Message.Keys and MK_XBUTTON2) <> 0 then
Btn := mbExtra2
else
Exit;
DoBeforeMouseMessage;
if (csCaptureMouse in ControlStyle) and (Btn in CaptureMouseButtons) then
begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.WMMButtonUp ',Name,':',ClassName);
{$ENDIF}
MouseCapture := False;
end;
DoMouseUp(Message, Btn);
end;
{------------------------------------------------------------------------------
Method: TControl.WMMouseWheel
Params: Msg: The message
Returns: nothing
event handler.
------------------------------------------------------------------------------}
procedure TControl.WMMouseWheel(var Message: TLMMouseEvent);
var
MousePos: TPoint;
begin
Assert(False, Format('Trace: [TControl.LMMouseWheel] %s', [ClassName]));
DoBeforeMouseMessage;
MousePos.X := Message.X;
MousePos.Y := Message.Y;
if DoMouseWheel(Message.State, Message.WheelDelta, MousePos) then
Message.Result := 1 // handled, skip further handling by interface
else
inherited;
end;
{------------------------------------------------------------------------------
TControl Click
------------------------------------------------------------------------------}
procedure TControl.Click;
begin
//DebugLn(['TControl.Click ',DbgSName(Self)]);
if (not (csDesigning in ComponentState)) and (ActionLink <> nil) and
((Action=nil) or (@FOnClick <> @Action.OnExecute) or Assigned(FOnClick)) then
ActionLink.Execute(Self)
else
if Assigned(FOnClick) then
FOnClick(Self);
end;
{------------------------------------------------------------------------------
TControl DialogChar
Do something useful with accelerators etc.
------------------------------------------------------------------------------}
function TControl.DialogChar(var Message: TLMKey): boolean;
begin
Result := False;
end;
procedure TControl.UpdateMouseCursor(X, Y: integer);
begin
//DebugLn(['TControl.UpdateMouseCursor ',DbgSName(Self)]);
if csDesigning in ComponentState then Exit;
if Screen.Cursor <> crDefault then Exit;
SetTempCursor(Cursor);
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
------------------------------------------------------------------------------}
procedure TControl.SetAutoSize(value : Boolean);
begin
If AutoSize <> Value then begin
FAutoSize := Value;
//debugln('TControl.SetAutoSize ',DbgSName(Self));
if FAutoSize then
AdjustSize;
end;
end;
{------------------------------------------------------------------------------
TControl DoAutoSize
IMPORTANT: Many Delphi controls override this method and many call this method
directly after setting some properties.
During handle creation not all interfaces can create complete Device Contexts
which are needed to calculate things like text size.
That's why you should always call AdjustSize instead of DoAutoSize.
------------------------------------------------------------------------------}
procedure TControl.DoAutoSize;
var
PreferredWidth: integer;
PreferredHeight: integer;
ResizeWidth: Boolean;
ResizeHeight: Boolean;
begin
// handled by TWinControl, or other descendants
ResizeWidth:=not WidthIsAnchored;
ResizeHeight:=not HeightIsAnchored;
if ResizeWidth or ResizeHeight then begin
PreferredWidth:=0;
PreferredHeight:=0;
GetPreferredSize(PreferredWidth,PreferredHeight);
if (not ResizeWidth) or (PreferredWidth<=0) then PreferredWidth:=Width;
if (not ResizeHeight) or (PreferredHeight<=0) then PreferredHeight:=Height;
SetBoundsKeepBase(Left,Top,PreferredWidth,PreferredHeight);
end;
end;
{------------------------------------------------------------------------------
TControl DoAllAutoSize
Run DoAutoSize until done.
------------------------------------------------------------------------------}
procedure TControl.DoAllAutoSize;
procedure AutoSizeControl(AControl: TControl);
var
AWinControl: TWinControl;
i: Integer;
begin
if AControl.AutoSizeDelayed then exit;
if not (cfAutoSizeNeeded in AControl.FControlFlags) then exit;
//DebugLn(['TControl.DoAllAutoSize.AutoSizeControl ',DbgSName(AControl),' AutoSize=',AControl.AutoSize,' IsControlVisible=',AControl.IsControlVisible]);
Exclude(AControl.FControlFlags, cfAutoSizeNeeded);
if not AControl.IsControlVisible then exit;
if AControl.AutoSize and
(not ((AControl.Parent = nil) and (csDesigning in AControl.ComponentState))) then
AControl.DoAutoSize;
if AControl is TWinControl then
begin
// recursive
AWinControl := TWinControl(AControl);
//DebugLn(['AutoSizeControl ',DbgSName(AWinControl)]);
AWinControl.AlignControl(nil);
for i := 0 to AWinControl.ControlCount - 1 do
AutoSizeControl(AWinControl.Controls[i]);
end;
end;
function CallAllOnResize(AControl: TControl): boolean;
// the OnResize event is called for Delphi compatibility after child resizes
var
AWinControl: TWinControl;
i: Integer;
begin
if AControl = nil then Exit(True);
Result := False;
if cfAutoSizeNeeded in FControlFlags then
begin
// something has changed => the autosizing must restart
exit;
end;
if AControl is TWinControl then
begin
AWinControl := TWinControl(AControl);
for i := 0 to AWinControl.ControlCount - 1 do
if not CallAllOnResize(AWinControl.Controls[i]) then Exit;
end;
AControl.Resize;
Result := True;
end;
begin
if Parent <> nil then raise Exception.Create('TControl.DoAllAutoSize Parent<>nil');
if AutoSizingAll then exit;
FAutoSizingAll := True;
if not (Self is TWinControl) then exit;
{$IFDEF VerboseAllAutoSize}
DebugLn(['TControl.DoAllAutoSize START ',DbgSName(Self)]);
{$ENDIF}
//writeln(GetStackTrace(true));
try
while not AutoSizeDelayed and (cfAutoSizeNeeded in FControlFlags) do
begin
{$IFDEF VerboseAllAutoSize}
DebugLn(['TControl.DoAllAutoSize LOOP ',DbgSName(Self),' ',dbgs(BoundsRect)]);
{$ENDIF}
AutoSizeControl(Self);
if not (cfAutoSizeNeeded in FControlFlags) then
CallAllOnResize(Self);
end;
finally
FAutoSizingAll := False;
end;
{$IFDEF VerboseAllAutoSize}
DebugLn(['TControl.DoAllAutoSize END ',DbgSName(Self),' ',dbgs(BoundsRect)]);
{$ENDIF}
end;
procedure TControl.AnchorSideChanged(TheAnchorSide: TAnchorSide);
begin
//debugln('TControl.AnchorSideChanged ',DbgSName(Self));
RequestAlign;
end;
procedure TControl.ForeignAnchorSideChanged(TheAnchorSide: TAnchorSide;
Operation: TAnchorSideChangeOperation);
var
Side: TAnchorKind;
AControl: TControl;
begin
AControl:=TheAnchorSide.Owner;
//debugln('TControl.ForeignAnchorSideChanged A Self=',DbgSName(Self),' TheAnchorSide.Owner=',DbgSName(TheAnchorSide.Owner),' Operation=',dbgs(ord(Operation)),' Anchor=',dbgs(TheAnchorSide.Kind));
if TheAnchorSide.Control=Self then begin
if FAnchoredControls=nil then
FAnchoredControls:=TFPList.Create;
if FAnchoredControls.IndexOf(AControl)<0 then
FAnchoredControls.Add(AControl);
end else if FAnchoredControls<>nil then begin
if TheAnchorSide.Owner<>nil then begin
for Side:=Low(TAnchorKind) to High(TAnchorKind) do begin
if (AControl.FAnchorSides[Side]<>nil)
and (AControl.FAnchorSides[Side].Control=Self) then begin
// still anchored
exit;
end;
end;
end;
FAnchoredControls.Remove(AControl);
end;
end;
function TControl.AutoSizePhases: TControlAutoSizePhases;
begin
if Parent<>nil then
Result:=Parent.AutoSizePhases
else
Result:=[];
end;
{------------------------------------------------------------------------------
function TControl.AutoSizeDelayed: boolean;
Returns true, if the DoAutoSize should skip now, because not all parameters
needed to calculate the AutoSize bounds are loaded or initialized.
------------------------------------------------------------------------------}
function TControl.AutoSizeDelayed: boolean;
begin
Result:=(FAutoSizingLockCount>0)
// no autosize during loading or destruction
or ([csLoading,csDestroying]*ComponentState<>[])
or (cfLoading in FControlFlags)
// no autosize for invisible controls
or (not IsControlVisible)
// if there is no parent, then this control is not visible
// (TCustomForm will override this)
or not AutoSizeCheckParent
// if there is a parent, ask it
or ((Parent<>nil) and Parent.AutoSizeDelayed);
{$IFDEF VerboseCanAutoSize}
if Result {and AutoSize} then begin
DbgOut('TControl.AutoSizeDelayed Self='+DbgSName(Self)+' ');
if FAutoSizingLockCount>0 then debugln('FAutoSizingLockCount=',dbgs(FAutoSizingLockCount))
else if csLoading in ComponentState then debugln('csLoading')
else if csDestroying in ComponentState then debugln('csDestroying')
else if cfLoading in FControlFlags then debugln('cfLoading')
else if not IsControlVisible then debugln('not IsControlVisible')
else if not AutoSizeCheckParent then debugln('not AutoSizeCheckParent')
else if ((Parent<>nil) and Parent.AutoSizeDelayed) then debugln('Parent.AutoSizeDelayed')
else debugln('?');
end;
{$ENDIF}
end;
function TControl.AutoSizeCheckParent: Boolean;
begin
Result := Parent <> nil;
end;
{------------------------------------------------------------------------------
TControl SetBoundsRect
------------------------------------------------------------------------------}
procedure TControl.SetBoundsRect(const ARect: TRect);
begin
{$IFDEF CHECK_POSITION}
if CheckPosition(Self) then
DebugLn('[TControl.SetBoundsRect] ',Name,':',ClassName);
{$ENDIF}
with ARect do
SetBounds(Left, Top, Max(Right - Left, 0), Max(Bottom - Top, 0));
end;
procedure TControl.SetBoundsRectForNewParent(const AValue: TRect);
begin
Include(FControlFlags,cfBoundsRectForNewParentValid);
FBoundsRectForNewParent:=AValue;
end;
{------------------------------------------------------------------------------
TControl SetClientHeight
------------------------------------------------------------------------------}
procedure TControl.SetClientHeight(Value: Integer);
begin
if csLoading in ComponentState then begin
FLoadedClientSize.cy:=Value;
Include(FControlFlags,cfClientHeightLoaded);
end else begin
// during loading the ClientHeight is not used to set the Height of the
// control, but only to restore autosizing. For example Anchors=[akBottom]
// needs ClientHeight.
SetClientSize(Point(ClientWidth, Value));
end;
end;
{------------------------------------------------------------------------------
TControl SetClientSize
------------------------------------------------------------------------------}
procedure TControl.SetClientSize(const Value: TPoint);
var
Client: TRect;
begin
Client := GetClientRect;
SetBounds(FLeft, FTop,
Width - Client.Right + Value.X, Height - Client.Bottom + Value.Y);
end;
{------------------------------------------------------------------------------
TControl SetClientWidth
------------------------------------------------------------------------------}
procedure TControl.SetClientWidth(Value: Integer);
begin
if csLoading in ComponentState then begin
FLoadedClientSize.cx:=Value;
Include(FControlFlags,cfClientWidthLoaded);
end else begin
// during loading the ClientWidth is not used to set the Width of the
// control, but only to restore autosizing. For example Anchors=[akRight]
// needs ClientWidth.
SetClientSize(Point(Value, ClientHeight));
end;
end;
{------------------------------------------------------------------------------
TControl SetTempCursor
------------------------------------------------------------------------------}
procedure TControl.SetTempCursor(Value: TCursor);
begin
if Parent<>nil then
Parent.SetTempCursor(Value);
end;
procedure TControl.ActiveDefaultControlChanged(NewControl: TControl);
begin
end;
procedure TControl.UpdateRolesForForm;
begin
// called by the form when the "role" controls DefaultControl or CancelControl
// has changed
end;
{------------------------------------------------------------------------------
TControl SetCursor
------------------------------------------------------------------------------}
procedure TControl.SetCursor(Value: TCursor);
begin
if FCursor <> Value then
begin
FCursor := Value;
if not (csDesigning in ComponentState) then
SetTempCursor(Value);
end;
end;
procedure TControl.SetDragCursor(const AValue: TCursor);
begin
if FDragCursor=AValue then exit;
FDragCursor:=AValue;
end;
procedure TControl.SetFont(Value: TFont);
begin
if FFont.IsEqual(Value) then exit;
FFont.Assign(Value);
Invalidate;
end;
{------------------------------------------------------------------------------
TControl SetEnabled
------------------------------------------------------------------------------}
procedure TControl.SetEnabled(Value: Boolean);
begin
if FEnabled <> Value
then begin
FEnabled := Value;
Perform(CM_ENABLEDCHANGED, 0, 0);
end;
end;
{------------------------------------------------------------------------------
TControl SetMouseCapture
------------------------------------------------------------------------------}
procedure TControl.SetMouseCapture(Value : Boolean);
begin
if (MouseCapture <> Value) or (not Value and (CaptureControl=Self))
then begin
{$IFDEF VerboseMouseCapture}
DebugLn('TControl.SetMouseCapture ',DbgSName(Self),' NewValue=',DbgS(Value));
{$ENDIF}
if Value
then SetCaptureControl(Self)
else SetCaptureControl(nil);
end
end;
{------------------------------------------------------------------------------
Method: TControl.SetHint
Params: Value: the text of the hint to be set
Returns: Nothing
Sets the hint text of a control
------------------------------------------------------------------------------}
procedure TControl.SetHint(const Value: TTranslateString);
begin
if FHint <> Value then FHint := Value;
end;
{------------------------------------------------------------------------------
TControl SetName
------------------------------------------------------------------------------}
procedure TControl.SetName(const Value: TComponentName);
var
ChangeText: Boolean;
begin
if Name=Value then exit;
ChangeText :=
(csSetCaption in ControlStyle) and not (csLoading in ComponentState) and
(Name = Text) and
((Owner = nil) or not (Owner is TControl) or not (csLoading in TControl(Owner).ComponentState));
inherited SetName(Value);
if ChangeText then Text := Value;
end;
{------------------------------------------------------------------------------
TControl Show
------------------------------------------------------------------------------}
procedure TControl.Show;
begin
if Parent <> nil then Parent.ShowControl(Self);
// do not switch the visible flag in design mode
if not (csDesigning in ComponentState) or
(csNoDesignVisible in ControlStyle) then Visible := True;
end;
{------------------------------------------------------------------------------
TControl Notification
------------------------------------------------------------------------------}
procedure TControl.Notification(AComponent: TComponent; Operation: TOperation);
var
Kind: TAnchorKind;
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
begin
if AComponent = PopupMenu then
PopupMenu := nil
else
if AComponent = Action then
Action := nil;
//debugln('TControl.Notification A ',DbgSName(Self),' ',DbgSName(AComponent));
for Kind := Low(TAnchorKind) to High(TAnchorKind) do
begin
if (FAnchorSides[Kind] <> nil) and (FAnchorSides[Kind].Control = AComponent) then
FAnchorSides[Kind].FControl := nil;
end;
end;
end;
procedure TControl.DoFloatMsg(ADockSource: TDragDockObject);
var
P: TPoint;
FloatHost: TWinControl;
begin
DebugLn(['TControl.DoFloatMsg ',DbgSName(Self),' Floating=',Floating]);
if Floating and (Parent <> nil) then
begin
P := Parent.ClientToScreen(Point(Left, Top));
with ADockSource.DockRect do
begin
Parent.BoundsRect := Bounds(Left + Parent.Left - P.X, Top + Parent.Top - P.Y,
Right - Left + Parent.Width - Width, Bottom - Top + Parent.Height - Height);
end;
end else
begin
FloatHost := CreateFloatingDockSite(ADockSource.DockRect);
if FloatHost <> nil then
begin
FloatHost.Caption := FloatHost.GetDockCaption(Self);
ADockSource.DragTarget := FloatHost;
FloatHost.Show;
end;
end;
end;
{------------------------------------------------------------------------------
TControl GetText
------------------------------------------------------------------------------}
function TControl.GetText: TCaption;
var
len: Integer;
begin
// Check if GetTextBuf is overridden, otherwise
// we can call RealGetText directly
if TMethod(@Self.GetTextBuf).Code = Pointer(@TControl.GetTextBuf)
then begin
Result := RealGetText;
end
else begin
// Bummer, we have to do it the compatible way.
DebugLn('Note: GetTextBuf is overridden for: ', Classname);
len := GetTextLen;
if len = 0
then begin
Result := '';
end
else begin
SetLength(Result, len+1); // make sure there is room for the extra #0
FillChar(Result[1], len, #0);
len := GetTextBuf(@Result[1], len+1);
SetLength(Result, len);
end;
end;
end;
{------------------------------------------------------------------------------
TControl RealGetText
------------------------------------------------------------------------------}
function TControl.RealGetText: TCaption;
begin
Result := FCaption;
end;
function TControl.GetTextLen: Integer;
begin
Result := Length(FCaption);
end;
function TControl.GetAction: TBasicAction;
begin
if ActionLink <> nil then
Result := ActionLink.Action
else
Result := nil;
end;
function TControl.GetActionLinkClass: TControlActionLinkClass;
begin
Result := TControlActionLink;
end;
{------------------------------------------------------------------------------
TControl IsCaptionStored
------------------------------------------------------------------------------}
function TControl.IsCaptionStored: Boolean;
begin
Result := (ActionLink = nil) or not ActionLink.IsCaptionLinked;
end;
function TControl.IsClientHeightStored: Boolean;
begin
Result:=false;
end;
function TControl.IsClientWidthStored: Boolean;
begin
Result:=false;
end;
function TControl.WidthIsAnchored: boolean;
var
CurAnchors: TAnchors;
begin
CurAnchors:=Anchors;
if Align<>alNone then CurAnchors:=CurAnchors+AnchorAlign[Align];
Result:=(CurAnchors*[akLeft,akRight]=[akLeft,akRight]);
if not Result then begin
if Parent<>nil then
Result:=Parent.ChildSizing.Layout<>cclNone;
end;
end;
function TControl.HeightIsAnchored: boolean;
var
CurAnchors: TAnchors;
begin
CurAnchors:=Anchors;
if Align<>alNone then CurAnchors:=CurAnchors+AnchorAlign[Align];
Result:=(CurAnchors*[akTop,akBottom]=[akTop,akBottom]);
if not Result then begin
if Parent<>nil then
Result:=Parent.ChildSizing.Layout<>cclNone;
end;
end;
procedure TControl.WMCancelMode(var Message: TLMessage);
begin
MouseCapture := False;
end;
function TControl.IsEnabledStored: Boolean;
begin
Result := (ActionLink = nil) or not ActionLink.IsEnabledLinked;
end;
function TControl.IsFontStored: Boolean;
begin
Result := not ParentFont;
end;
function TControl.IsHintStored: Boolean;
begin
Result := (ActionLink = nil) or not ActionLink.IsHintLinked;
end;
{------------------------------------------------------------------------------
TControl InvalidateControl
------------------------------------------------------------------------------}
procedure TControl.InvalidateControl(CtrlIsVisible, CtrlIsOpaque: Boolean);
var
Rect: TRect;
function BackgroundClipped: Boolean;
var
R: TRect;
List: TFPList;
I: Integer;
C: TControl;
begin
Result := True;
List := FParent.FControls;
if List<>nil then begin
I := List.IndexOf(Self);
while I > 0 do
begin
Dec(I);
C := TControl(List[I]);
if not (C is TWinControl) then
with C do
if IsControlVisible and (csOpaque in ControlStyle) then
begin
IntersectRect(R, Rect, BoundsRect);
if EqualRect(R, Rect) then Exit;
end;
end;
end;
Result := False;
end;
begin
//DebugLn(['TControl.InvalidateControl ',DbgSName(Self)]);
if (Parent=nil) or (not Parent.HandleAllocated)
or ([csLoading,csDestroying]*Parent.ComponentState<>[])
then exit;
// Note: it should invalidate, when this control is loaded/destroyed, but parent not
if (CtrlIsVisible or ((csDesigning in ComponentState)
and not (csNoDesignVisible in ControlStyle)))
then begin
Rect := BoundsRect;
InvalidateRect(Parent.Handle, @Rect, not (CtrlIsOpaque or
(csOpaque in Parent.ControlStyle) or BackgroundClipped));
end;
end;
{------------------------------------------------------------------------------
procedure TControl.InvalidateControl(CtrlIsVisible, CtrlIsOpaque,
IgnoreWinControls: Boolean);
------------------------------------------------------------------------------}
procedure TControl.InvalidateControl(CtrlIsVisible, CtrlIsOpaque,
IgnoreWinControls: Boolean);
begin
//DebugLn(['TControl.InvalidateControl ',DbgSName(Self)]);
if IgnoreWinControls and (Self is TWinControl) then exit;
InvalidateControl(CtrlIsVisible,CtrlIsOpaque);
end;
{------------------------------------------------------------------------------
TControl Refresh
------------------------------------------------------------------------------}
procedure TControl.Refresh;
begin
Repaint;
end;
{------------------------------------------------------------------------------
TControl Repaint
------------------------------------------------------------------------------}
procedure TControl.Repaint;
var
DC: HDC;
begin
if (Parent=nil) or (not Parent.HandleAllocated)
or (csDestroying in ComponentState) then exit;
if IsVisible then
if csOpaque in ControlStyle then
begin
{$IFDEF VerboseDsgnPaintMsg}
if csDesigning in ComponentState then
DebugLn('TControl.Repaint A ',Name,':',ClassName);
{$ENDIF}
DC := GetDC(Parent.Handle);
try
IntersectClipRect(DC, Left, Top, Left + Width, Top + Height);
Parent.PaintControls(DC, Self);
finally
ReleaseDC(Parent.Handle, DC);
end;
end else
begin
Invalidate;
Update;
end;
end;
{------------------------------------------------------------------------------
TControl Resize
Calls OnResize
-------------------------------------------------------------------------------}
procedure TControl.Resize;
begin
if ([csLoading,csDestroying]*ComponentState<>[]) then exit;
if AutoSizeDelayed then exit;
if (FLastResizeWidth<>Width) or (FLastResizeHeight<>Height)
or (FLastResizeClientWidth<>ClientWidth)
or (FLastResizeClientHeight<>ClientHeight) then begin
//if AnsiCompareText('NOTEBOOK',Name)=0 then
{DebugLn(['[TControl.Resize] ',Name,':',ClassName,
' Last=',FLastResizeWidth,',',FLastResizeHeight,
' LastClient=',FLastResizeClientWidth,',',FLastResizeClientHeight,
' New=',Width,',',Height,
' NewClient=',ClientWidth,',',ClientHeight]);}
FLastResizeWidth:=Width;
FLastResizeHeight:=Height;
FLastResizeClientWidth:=ClientWidth;
FLastResizeClientHeight:=ClientHeight;
DoOnResize;
end;
end;
procedure TControl.Loaded;
function FindLoadingControl(AControl: TControl): TControl;
var
i: Integer;
AWinControl: TWinControl;
begin
if csLoading in AControl.ComponentState then exit(AControl);
if AControl is TWinControl then begin
AWinControl:=TWinControl(AControl);
for i:=0 to AWinControl.ControlCount-1 do
begin
Result:=FindLoadingControl(AWinControl.Controls[i]);
if Result<>nil then exit;
end;
end;
Result:=nil;
end;
procedure ClearLoadingFlags(AControl: TControl);
var
i: Integer;
AWinControl: TWinControl;
begin
Exclude(AControl.FControlFlags,cfLoading);
if AControl is TWinControl then begin
AWinControl:=TWinControl(AControl);
for i:=0 to AWinControl.ControlCount-1 do
ClearLoadingFlags(AWinControl.Controls[i]);
end;
end;
procedure CheckLoading(AControl: TControl);
var
TopParent: TControl;
begin
TopParent:=AControl;
while (TopParent.Parent<>nil)
and (cfLoading in TopParent.Parent.FControlFlags) do
TopParent:=TopParent.Parent;
if FindLoadingControl(TopParent)<>nil then exit;
// all components on the form finished loading
ClearLoadingFlags(TopParent);
// call LoadedAll
DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.Loaded.CheckLoading'){$ENDIF};
try
AControl.LoadedAll;
finally
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.Loaded.CheckLoading'){$ENDIF};
end;
end;
var
UseClientWidthForWidth: boolean;
UseClientHeightForHeight: boolean;
NewWidth: LongInt;
NewHeight: LongInt;
begin
inherited Loaded;
{DebugLn(['TControl.Loaded A ',DbgSName(Self),
' LoadedClientWidth=',cfClientWidthLoaded in FControlFlags,'=',FLoadedClientSize.X,
' LoadedClientHeight=',cfClientHeightLoaded in FControlFlags,'=',FLoadedClientSize.Y,
' LoadedBounds=',DbgS(FReadBounds),
'']);}
UseClientWidthForWidth:=(not (cfWidthLoaded in FControlFlags))
and (cfClientWidthLoaded in FControlFlags);
UseClientHeightForHeight:=(not (cfHeightLoaded in FControlFlags))
and (cfClientHeightLoaded in FControlFlags);
if UseClientWidthForWidth or UseClientHeightForHeight then begin
//DebugLn(['TControl.Loaded ',DbgSName(Self),' Note: Width and/or Height were not set during loading, using ClientWidth/ClientHeight']);
NewWidth:=Width;
if UseClientWidthForWidth then
NewWidth:=FLoadedClientSize.cx;
NewHeight:=Height;
if UseClientHeightForHeight then
NewHeight:=FLoadedClientSize.cy;
SetBoundsKeepBase(Left,Top,NewWidth,NewHeight);
end;
if Assigned(Parent) then
begin
if ParentColor then
begin
Color := Parent.Color;
FParentColor := True;
end;
if ParentFont then
begin
Font := Parent.Font;
FParentFont := True;
end;
if ParentBidiMode then
begin
BiDiMode := Parent.BiDiMode;
FParentBidiMode := True;
end;
if ParentShowHint then
begin
ShowHint := Parent.ShowHint;
FParentShowHint := True;
end;
end;
UpdateBaseBounds(true,true,true);
// store designed width and height for undocking
FUndockHeight := Height;
FUndockWidth := Width;
if Action <> nil then ActionChange(Action, True);
CheckLoading(Self);
end;
procedure TControl.LoadedAll;
begin
AdjustSize;
Resize;
CheckOnChangeBounds;
end;
{------------------------------------------------------------------------------
procedure TControl.DefineProperties(Filer: TFiler);
------------------------------------------------------------------------------}
procedure TControl.DefineProperties(Filer: TFiler);
begin
// Optimiziation:
// do not call inherited: TComponent only defines 'Left' and 'Top' and
// TControl has them as regular properties.
end;
{------------------------------------------------------------------------------
procedure TControl.AssignTo(Dest: TPersistent);
------------------------------------------------------------------------------}
procedure TControl.AssignTo(Dest: TPersistent);
begin
if Dest is TCustomAction then
with TCustomAction(Dest) do begin
Enabled := Self.Enabled;
Hint := Self.Hint;
Caption := Self.Caption;
Visible := Self.Visible;
OnExecute := Self.OnClick;
HelpContext := Self.HelpContext;
HelpKeyword := Self.HelpKeyword;
HelpType := Self.HelpType;
end
else inherited AssignTo(Dest);
end;
procedure TControl.ReadState(Reader: TReader);
begin
Include(FControlFlags,cfLoading);
DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ReadState'){$ENDIF};
try
inherited ReadState(Reader);
finally
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ReadState'){$ENDIF};
end;
end;
procedure TControl.FormEndUpdated;
// called when control is on a form and EndFormUpdate reached 0
// it is called recursively
begin
end;
{------------------------------------------------------------------------------
TControl SetBounds
------------------------------------------------------------------------------}
procedure TControl.SetBounds(ALeft, ATop, AWidth, AHeight: integer);
begin
ChangeBounds(ALeft, ATop, AWidth, AHeight, false);
end;
{------------------------------------------------------------------------------
TControl SetConstraints
------------------------------------------------------------------------------}
procedure TControl.SetConstraints(const Value : TSizeConstraints);
begin
FConstraints.Assign(Value);
end;
{------------------------------------------------------------------------------
TControl SetAlign
------------------------------------------------------------------------------}
procedure TControl.SetAlign(Value: TAlign);
var
OldAlign: TAlign;
begin
if FAlign = Value then exit;
//DebugLn(['TControl.SetAlign ',DbgSName(Self),' Old=',AlignNames[FAlign],' New=',AlignNames[Value],' ',Anchors<>AnchorAlign[FAlign]]);
OldAlign := FAlign;
FAlign := Value;
// if anchors were on default then change them to new default
// This is done for Delphi compatibility.
if (Anchors = AnchorAlign[OldAlign]) and (Anchors <> AnchorAlign[FAlign]) then
Anchors := AnchorAlign[FAlign]
else
RequestAlign;
end;
{------------------------------------------------------------------------------
TControl SetAnchors
------------------------------------------------------------------------------}
procedure TControl.SetAnchors(const AValue: TAnchors);
begin
if Anchors = AValue then Exit;
FAnchors := AValue;
AdjustSize;
end;
{------------------------------------------------------------------------------
TControl RequestAlign
Requests the parent to realign all brothers
------------------------------------------------------------------------------}
procedure TControl.RequestAlign;
begin
AdjustSize;
end;
procedure TControl.UpdateBaseBounds(StoreBounds,
StoreParentClientSize, UseLoadedValues: boolean);
var
NewBaseBounds: TRect;
NewBaseParentClientSize: TSize;
begin
if (csLoading in ComponentState) or (fBaseBoundsLock>0) then exit;
if StoreBounds then
NewBaseBounds:=BoundsRect
else
NewBaseBounds:=FBaseBounds;
if StoreParentClientSize then begin
if Parent<>nil then begin
NewBaseParentClientSize:=Size(Parent.ClientWidth,Parent.ClientHeight);
if UseLoadedValues then begin
if cfClientWidthLoaded in Parent.FControlFlags then
NewBaseParentClientSize.cx:=Parent.FLoadedClientSize.cx;
if cfClientHeightLoaded in Parent.FControlFlags then
NewBaseParentClientSize.cy:=Parent.FLoadedClientSize.cy;
end;
end else
NewBaseParentClientSize:=Size(0,0);
end else
NewBaseParentClientSize:=FBaseParentClientSize;
if CompareRect(@NewBaseBounds,@FBaseBounds)
and (NewBaseParentClientSize.cx=FBaseParentClientSize.cx)
and (NewBaseParentClientSize.cy=FBaseParentClientSize.cy)
then exit;
//if csDesigning in ComponentState then
{$IFDEF CHECK_POSITION}
if CheckPosition(Self) then
DebugLn(['TControl.UpdateBaseBounds '+DbgSName(Self),
' OldBounds='+dbgs(FBaseBounds),
' OldParentClientSize='+dbgs(FBaseParentClientSize),
' NewBounds='+dbgs(NewBaseBounds),
' NewParentClientSize='+dbgs(NewBaseParentClientSize),
'']);
{$ENDIF}
FBaseBounds:=NewBaseBounds;
Include(FControlFlags,cfBaseBoundsValid);
FBaseParentClientSize:=NewBaseParentClientSize;
end;
procedure TControl.WriteLayoutDebugReport(const Prefix: string);
var
a: TAnchorKind;
NeedSeparator: Boolean;
begin
DbgOut(Prefix,'TControl.WriteLayoutDebugReport ');
DbgOut(DbgSName(Self),' Bounds=',dbgs(BoundsRect));
if Align<>alNone then
DbgOut(' Align=',AlignNames[Align]);
DbgOut(' Anchors=[');
NeedSeparator:=false;
for a:=Low(TAnchorKind) to High(TAnchorKind) do begin
if a in Anchors then begin
if NeedSeparator then DbgOut(',');
DbgOut(dbgs(a));
if AnchorSide[a].Control<>nil then begin
DbgOut('(',DbgSName(AnchorSide[a].Control),')');
end;
NeedSeparator:=true;
end;
end;
DbgOut(']');
DebugLn;
end;
procedure TControl.UpdateAnchorRules;
begin
UpdateBaseBounds(true,true,false);
end;
{------------------------------------------------------------------------------
TControl SetDragmode
------------------------------------------------------------------------------}
procedure TControl.SetDragMode(Value: TDragMode);
begin
if FDragMode = Value then exit;
FDragMode := Value;
end;
function TControl.GetDefaultDockCaption: String;
begin
Result := Caption;
end;
{------------------------------------------------------------------------------
TControl DockTrackNoTarget
------------------------------------------------------------------------------}
procedure TControl.DockTrackNoTarget(Source: TDragDockObject; X, Y: Integer);
begin
PositionDockRect(Source);
end;
{------------------------------------------------------------------------------
TControl SetLeft
------------------------------------------------------------------------------}
procedure TControl.SetLeft(Value: Integer);
begin
{$IFDEF CHECK_POSITION}
if CheckPosition(Self) then
DebugLn('[TControl.SetLeft] ',Name,':',ClassName,' ',DbgS(Value));
{$ENDIF}
if csLoading in ComponentState then
begin
inc(FReadBounds.Right, Value - FReadBounds.Left);
FReadBounds.Left := Value;
Include(FControlFlags, cfLeftLoaded);
end;
SetBounds(Value, FTop, FWidth, FHeight);
end;
{------------------------------------------------------------------------------
TControl SetTop
------------------------------------------------------------------------------}
procedure TControl.SetTop(Value: Integer);
begin
{$IFDEF CHECK_POSITION}
if CheckPosition(Self) then
DebugLn('[TControl.SetTop] ',Name,':',ClassName,' ',Dbgs(Value));
{$ENDIF}
if csLoading in ComponentState then
begin
inc(FReadBounds.Bottom,Value - FReadBounds.Top);
FReadBounds.Top := Value;
Include(FControlFlags, cfTopLoaded);
end;
SetBounds(FLeft, Value, FWidth, FHeight);
end;
{------------------------------------------------------------------------------
TControl SetWidth
------------------------------------------------------------------------------}
procedure TControl.SetWidth(Value: Integer);
procedure CheckDesignBounds;
begin
// the user changed the width
if Value<0 then
raise Exception.Create(
'TWinControl.SetBounds ('+DbgSName(Self)+'): Negative width '
+dbgs(Value)+' not allowed.');
if Value>=10000 then
raise Exception.Create(
'TWinControl.SetBounds ('+DbgSName(Self)+'): Width '
+dbgs(Value)+' not allowed.');
end;
begin
{$IFDEF CHECK_POSITION}
if CheckPosition(Self) then
DebugLn('[TControl.SetWidth] ',Name,':',ClassName,' ',dbgs(Value));
{$ENDIF}
if csLoading in ComponentState then
begin
FReadBounds.Right := FReadBounds.Left+Value;
Include(FControlFlags, cfWidthLoaded);
end;
if [csDesigning, csDestroying, csLoading] * ComponentState = [csDesigning] then
CheckDesignBounds;
SetBounds(FLeft, FTop, Max(0, Value), FHeight);
end;
class procedure TControl.WSRegisterClass;
begin
inherited WSRegisterClass;
RegisterPropertyToSkip(TControl, 'IsControl', 'VCL compatibility property', '');
RegisterPropertyToSkip(TControl, 'DesignSize', 'VCL compatibility property', '');
RegisterControl;
end;
function TControl.GetCursor: TCursor;
begin
Result := FCursor;
end;
{------------------------------------------------------------------------------
TControl SetHeight
------------------------------------------------------------------------------}
procedure TControl.SetHeight(Value: Integer);
procedure CheckDesignBounds;
begin
// the user changed the height
if Value<0 then
raise Exception.Create(
'TWinControl.SetHeight ('+DbgSName(Self)+'): Negative height '
+dbgs(Value)+' not allowed.');
if Value>=10000 then
raise Exception.Create(
'TWinControl.SetBounds ('+DbgSName(Self)+'): Height '
+dbgs(Value)+' not allowed.');
end;
begin
{$IFDEF CHECK_POSITION}
if CheckPosition(Self) then
DebugLn('[TControl.SetHeight] ',Name,':',ClassName,' ',dbgs(Value));
{$ENDIF}
if csLoading in ComponentState then
begin
FReadBounds.Bottom := FReadBounds.Top + Value;
Include(FControlFlags, cfHeightLoaded);
end;
if [csDesigning, csDestroying, csLoading] * ComponentState = [csDesigning] then
CheckDesignBounds;
SetBounds(FLeft, FTop, FWidth, Max(0, Value));
end;
{------------------------------------------------------------------------------
procedure TControl.SetHelpContext(const AValue: THelpContext);
------------------------------------------------------------------------------}
procedure TControl.SetHelpContext(const AValue: THelpContext);
begin
if FHelpContext=AValue then exit;
if not (csLoading in ComponentState) then
FHelpType := htContext;
FHelpContext:=AValue;
end;
{------------------------------------------------------------------------------
procedure TControl.SetHelpKeyword(const AValue: String);
------------------------------------------------------------------------------}
procedure TControl.SetHelpKeyword(const AValue: String);
begin
if FHelpKeyword=AValue then exit;
if not (csLoading in ComponentState) then
FHelpType := htKeyword;
FHelpKeyword:=AValue;
end;
procedure TControl.SetHostDockSite(const AValue: TWinControl);
begin
if AValue=FHostDockSite then exit;
Dock(AValue, BoundsRect);
end;
{------------------------------------------------------------------------------
procedure TControl.SetParent(NewParent : TWinControl);
------------------------------------------------------------------------------}
procedure TControl.SetParent(NewParent: TWinControl);
begin
if FParent = NewParent then exit;
DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetParent'){$ENDIF};
try
CheckNewParent(NewParent);
if FParent <> nil then FParent.RemoveControl(Self);
if cfBoundsRectForNewParentValid in FControlFlags then
begin
Exclude(FControlFlags, cfBoundsRectForNewParentValid);
BoundsRect := BoundsRectForNewParent;
end;
if NewParent <> nil then NewParent.InsertControl(Self);
finally
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetParent'){$ENDIF};
end;
end;
{------------------------------------------------------------------------------
TControl SetParentComponent
------------------------------------------------------------------------------}
procedure TControl.SetParentComponent(NewParentComponent: TComponent);
begin
if (NewParentComponent is TWinControl) then
SetParent(TWinControl(NewParentComponent));
end;
{------------------------------------------------------------------------------
procedure TControl.SetParentColor(Value : Boolean);
------------------------------------------------------------------------------}
procedure TControl.SetParentColor(Value : Boolean);
begin
if FParentColor <> Value then
begin
FParentColor := Value;
if Assigned(FParent) and not (csReading in ComponentState) then
Perform(CM_PARENTCOLORCHANGED, 0, 0);
end;
end;
procedure TControl.SetParentFont(Value: Boolean);
begin
if FParentFont <> Value then
begin
FParentFont := Value;
if Assigned(FParent) and not (csReading in ComponentState) then
Perform(CM_PARENTFONTCHANGED, 0, 0);
end;
end;
{------------------------------------------------------------------------------
TControl SetParentShowHint
------------------------------------------------------------------------------}
procedure TControl.SetParentShowHint(Value : Boolean);
begin
if FParentShowHint <> Value then
begin
FParentShowHint := Value;
if Assigned(FParent) and not (csReading in ComponentState) then
Perform(CM_PARENTSHOWHINTCHANGED, 0, 0);
end;
end;
{------------------------------------------------------------------------------
TControl SetPopupMenu
------------------------------------------------------------------------------}
procedure TControl.SetPopupMenu(Value: TPopupMenu);
begin
FPopupMenu := Value;
if FPopupMenu <> nil then
FPopupMenu.FreeNotification(Self);
end;
{------------------------------------------------------------------------------
TControl WMMouseMove
------------------------------------------------------------------------------}
procedure TControl.WMMouseMove(var Message: TLMMouseMove);
begin
{$IFDEF VerboseMouseBugfix}
DebugLn(['[TControl.WMMouseMove] ',Name,':',ClassName,' ',Message.XPos,',',Message.YPos]);
{$ENDIF}
DoBeforeMouseMessage;
UpdateMouseCursor(Message.XPos,Message.YPos);
if not (csNoStdEvents in ControlStyle) then
with Message do
MouseMove(KeystoShiftState(Word(Keys)), XPos, YPos);
end;
{------------------------------------------------------------------------------
TControl MouseDown
------------------------------------------------------------------------------}
procedure TControl.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
P: TPoint;
Form: TCustomForm;
begin
if (not (Self is TWinControl)) or (not TWinControl(Self).CanFocus) then
begin
Form := GetParentForm(Self);
if (Form <> nil) and (Form.ActiveControl <> nil) then
Form.ActiveControl.EditingDone;
end;
if (Button in [mbLeft, mbRight]) and DragManager.IsDragging then
begin
P := ClientToScreen(Point(X,Y));
DragManager.MouseDown(Button, Shift, P.X, P.Y);
end;
if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X,Y);
end;
{------------------------------------------------------------------------------
TControl MouseMove
------------------------------------------------------------------------------}
procedure TControl.MouseMove(Shift: TShiftState; X, Y: Integer);
var
P: TPoint;
begin
if DragManager.IsDragging then
begin
P := ClientToScreen(Point(X, Y));
DragManager.MouseMove(Shift, P.X, P.Y);
end;
if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y);
end;
{------------------------------------------------------------------------------
TControl MouseUp
------------------------------------------------------------------------------}
procedure TControl.MouseUp(Button: TMouseButton; Shift:TShiftState;
X, Y: Integer);
begin
if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X,Y);
end;
procedure TControl.MouseEnter;
begin
//DebugLn('TControl.MouseEnter ',Name,':',ClassName,' ',Assigned(FOnMouseEnter));
if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
end;
procedure TControl.MouseLeave;
begin
//DebugLn('TControl.MouseLeave ',Name,':',ClassName,' ',Assigned(FOnMouseLeave));
if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
end;
{------------------------------------------------------------------------------
procedure TControl.CaptureChanged;
------------------------------------------------------------------------------}
procedure TControl.CaptureChanged;
begin
if DragManager.IsDragging then
DragManager.CaptureChanged(Self);
end;
{------------------------------------------------------------------------------
TControl SetShowHint
------------------------------------------------------------------------------}
procedure TControl.SetShowHint(Value : Boolean);
begin
if FShowHint <> Value then
begin
FShowHint := Value;
FParentShowHint := False;
Perform(CM_SHOWHINTCHANGED, 0, 0);
end;
end;
{------------------------------------------------------------------------------
TControl SetVisible
------------------------------------------------------------------------------}
procedure TControl.SetVisible(Value : Boolean);
var
AsWincontrol: TWinControl;
begin
if FVisible <> Value then
begin
//DebugLn(['TControl.SetVisible ',DbgSName(Self),' NewVisible=',Value]);
DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetVisible'){$ENDIF};
try
VisibleChanging;
FVisible := Value;
try
// create/destroy handle
Perform(CM_VISIBLECHANGED, WParam(Ord(Value)), 0);// see TWinControl.CMVisibleChanged
if (Self is TWinControl) then
AsWincontrol := TWinControl(Self)
else
AsWincontrol := nil;
InvalidatePreferredSize;
if AsWincontrol <> nil then
AsWincontrol.InvalidatePreferredChildSizes;
AdjustSize;
if (not Visible) and (Parent<>nil) then
begin
// control became invisible, so AdjustSize was not propagated
// propagate
Parent.InvalidatePreferredSize;
Parent.AdjustSize;
end;
finally
VisibleChanged;
end;
finally
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetVisible'){$ENDIF};
end;
end;
if (csLoading in ComponentState) then
ControlState := ControlState + [csVisibleSetInLoading];
end;
procedure TControl.DoOnParentHandleDestruction;
begin
// nothing, implement in descendats
end;
{------------------------------------------------------------------------------
TControl.SetZOrder
------------------------------------------------------------------------------}
procedure TControl.SetZOrder(Topmost: Boolean);
const
POSITION: array[Boolean] of Integer = (0, MaxInt);
begin
if FParent = nil then exit;
FParent.SetChildZPosition(Self, POSITION[TopMost]);
end;
{------------------------------------------------------------------------------
function TControl.HandleObjectShouldBeVisible
------------------------------------------------------------------------------}
function TControl.HandleObjectShouldBeVisible: boolean;
begin
Result := (not (csDestroying in ComponentState)) and IsControlVisible;
if Result and Assigned(Parent) then
Result := Parent.HandleObjectShouldBeVisible;
//DebugLn(['TControl.HandleObjectShouldBeVisible ',DbgSName(Self),' ',Result]);
end;
{------------------------------------------------------------------------------
procedure TControl Hide
------------------------------------------------------------------------------}
procedure TControl.Hide;
begin
Visible := False;
end;
{------------------------------------------------------------------------------
function TControl.ParentDestroyingHandle: boolean;
Returns whether any parent is destroying it's handle (and its children's)
------------------------------------------------------------------------------}
function TControl.ParentDestroyingHandle: boolean;
var
CurControl: TControl;
begin
Result:=true;
CurControl:=Self;
while CurControl<>nil do begin
if csDestroyingHandle in CurControl.ControlState then
exit;
CurControl:=CurControl.Parent;
end;
Result:=false;
end;
{------------------------------------------------------------------------------
function TControl.ParentHandlesAllocated: boolean;
------------------------------------------------------------------------------}
function TControl.ParentHandlesAllocated: boolean;
begin
Result:=(Parent<>nil) and (Parent.ParentHandlesAllocated);
end;
{------------------------------------------------------------------------------
procedure TControl.InitiateAction;
------------------------------------------------------------------------------}
procedure TControl.InitiateAction;
begin
if ActionLink <> nil then ActionLink.Update;
end;
procedure TControl.ShowHelp;
begin
if HelpType=htContext then begin
if HelpContext<>0 then begin
Application.HelpContext(Self,ClientToScreen(Point(0,0)),HelpContext);
exit;
end;
end else begin
if HelpKeyword<>'' then begin
Application.HelpKeyword(Self,ClientToScreen(Point(0,0)),HelpKeyword);
exit;
end;
end;
if Parent<>nil then Parent.ShowHelp;
end;
function TControl.HasHelp: Boolean;
begin
if HelpType=htContext then
Result:=HelpContext<>0
else
Result:=HelpKeyword<>'';
end;
{------------------------------------------------------------------------------
procedure TControl.Dock(NewDockSite: TWinControl; ARect: TRect);
Docks this control into NewDockSite at ARect.
------------------------------------------------------------------------------}
procedure TControl.Dock(NewDockSite: TWinControl; ARect: TRect);
procedure RaiseAlreadyDocking;
begin
RaiseGDBException('TControl.Dock '+Name+':'+ClassName+' csDocking in FControlState');
end;
var
OldHostDockSite: TWinControl;
begin
if (csDocking in FControlState) then
RaiseAlreadyDocking;
// dock
DisableAutoSizing;
Include(FControlState, csDocking);
try
OldHostDockSite:=HostDockSite;
if OldHostDockSite<>NewDockSite then begin
// HostDockSite will change -> prepare
if (OldHostDockSite<>nil) and (OldHostDockSite.FDockClients<>nil) then
OldHostDockSite.FDockClients.Remove(Self);
if (NewDockSite<>nil) and (NewDockSite.FDockClients<>nil) then
NewDockSite.FDockClients.Add(Self);
end;
//debugln(['TControl.Dock A ',DbgSName(Self),' NewDockSite=',DbgSName(NewDockSite),' ',NewDockSite.Visible]);
DoDock(NewDockSite,ARect);
if FHostDockSite<>NewDockSite then
begin
// HostDockSite has changed -> commit
OldHostDockSite := FHostDockSite;
FHostDockSite := NewDockSite;
if NewDockSite<>nil then NewDockSite.DoAddDockClient(Self,ARect);
if OldHostDockSite<>nil then OldHostDockSite.DoRemoveDockClient(Self);
end;
finally
if (FHostDockSite<>NewDockSite) and (NewDockSite.FDockClients<>nil) then
NewDockSite.FDockClients.Remove(Self);
Exclude(FControlState, csDocking);
end;
EnableAutoSizing;
//DebugLn(['TControl.Dock END ',DbgSName(Self),' ',DbgSName(HostDockSite)]);
end;
{------------------------------------------------------------------------------
function TControl.ManualDock(NewDockSite: TWinControl; DropControl: TControl;
ControlSide: TAlign): Boolean;
Docks this control to DropControl or on NewDockSite.
If DropControl is not nil, ControlSide defines on which side of DropControl
this control is docked. (alNone,alClient for stacked in pages). DropControl
will become part of a TDockManager.
If DropControl is nil, then DropControl becomes a normal child of NewDockSite
and ControlSide is ignored.
------------------------------------------------------------------------------}
function TControl.ManualDock(NewDockSite: TWinControl; DropControl: TControl;
ControlSide: TAlign; KeepDockSiteSize: Boolean): Boolean;
var
NewBounds: TRect;
DockObject: TDragDockObject;
NewPosition: TPoint;
begin
if DropControl<>nil then
DropControl.DisableAutoSizing;
if NewDockSite<>nil then
NewDockSite.DisableAutoSizing;
if (NewDockSite=nil) then begin
// undock / float this control
// float the control at the same screen position
if HostDockSiteManagerAvailable(HostDockSite) then begin
HostDockSite.DockManager.GetControlBounds(Self,NewBounds);
NewBounds.TopLeft:=HostDockSite.ClientToScreen(NewBounds.TopLeft);
end else begin
NewBounds.TopLeft:=ControlOrigin;
end;
NewBounds := Bounds(NewBounds.Left,NewBounds.Top,UndockWidth,UndockHeight);
//DebugLn('TControl.ManualDock ',Name,' NewDockSite=nil HostDockSiteManagerAvailable=',dbgs(HostDockSiteManagerAvailable(HostDockSite)),' NewBounds=',dbgs(NewBounds));
Result := ManualFloat(NewBounds);
end
else
begin
// dock / unfloat this control
CalculateDockSizes;
Result := (HostDockSite=nil);
if not Result then begin
// undock from old HostSite
// - this only undocks from the DockManager
// - this control still uses the DockSite as parent control
// Note: This can *not* be combined with ManualFloat, because that would
// create a new HostDockSite
//DebugLn('TControl.ManualDock UNDOCKING ',Name);
Result:=HostDockSite.DoUndock(NewDockSite,Self);
end;
if Result then begin
//DebugLn('TControl.ManualDock DOCKING ',Name);
// create TDragDockObject for docking parameters
DockObject := TDragDockObject.Create(Self);
try
// get current screen coordinates
NewPosition:=ControlOrigin;
// initialize DockObject
with DockObject do begin
FDragTarget := NewDockSite;
FDropAlign := ControlSide;
FDropOnControl := DropControl;
FIncreaseDockArea := not KeepDockSiteSize;
DockRect := Bounds(NewPosition.X,NewPosition.Y,Width,Height);
end;
// map from screen coordinates to new HostSite coordinates
NewPosition:=NewDockSite.ScreenToClient(NewPosition);
// DockDrop
//DebugLn('TControl.ManualDock DOCKDROP ',Name,' DockRect=',dbgs(DockObject.DockRect),' NewPos=',dbgs(NewPosition));
NewDockSite.DockDrop(DockObject,NewPosition.X,NewPosition.Y);
finally
DockObject.Free;
end;
end;
end;
if NewDockSite<>nil then
NewDockSite.EnableAutoSizing;
if DropControl<>nil then
DropControl.EnableAutoSizing;
end;
{------------------------------------------------------------------------------
function TControl.ManualFloat(TheScreenRect: TRect;
KeepDockSiteSize: Boolean = true): Boolean;
Undock and float.
Float means here: create the floating dock site and dock this control into it.
Exception: Forms do not need float dock sites and float on their own.
------------------------------------------------------------------------------}
function TControl.ManualFloat(TheScreenRect: TRect;
KeepDockSiteSize: Boolean): Boolean;
var
FloatHost: TWinControl;
begin
DebugLn(['TControl.ManualFloat ',DbgSName(Self)]);
DisableAutoSizing;
// undock from old host dock site
if HostDockSite = nil then
begin
Result := True;
if Parent <> nil then
Parent.DoUndockClientMsg(nil, Self);
end
else
begin
Result := HostDockSite.DoUndock(nil, Self, KeepDockSiteSize);
end;
// create new float dock site and dock this control into it.
if Result then
begin
FloatHost := CreateFloatingDockSite(TheScreenRect);
//debugln('TControl.ManualFloat A '+Name,':',ClassName,' ',dbgs(TheScreenRect),' FloatHost=',dbgs(FloatHost<>nil));
if FloatHost <> nil then
begin
// => dock this control into it.
FloatHost.Caption := FloatHost.GetDockCaption(Self);
FloatHost.Visible := True;
Dock(FloatHost,Rect(0, 0, FloatHost.ClientWidth, FloatHost.ClientHeight))
end
else
Dock(nil, TheScreenRect);
end;
EnableAutoSizing;
end;
{------------------------------------------------------------------------------
function TControl.ReplaceDockedControl(Control: TControl;
NewDockSite: TWinControl; DropControl: TControl; ControlSide: TAlign
): Boolean;
------------------------------------------------------------------------------}
function TControl.ReplaceDockedControl(Control: TControl;
NewDockSite: TWinControl; DropControl: TControl; ControlSide: TAlign
): Boolean;
var
OldDockSite: TWinControl;
begin
Result := False;
DisableAutoSizing;
OldDockSite := Control.HostDockSite;
if (OldDockSite<>nil) and (not HostDockSiteManagerAvailable(OldDockSite)) then
exit;
if OldDockSite <> nil then
OldDockSite.DockManager.SetReplacingControl(Control);
try
ManualDock(OldDockSite,nil,alTop);
finally
if OldDockSite <> nil then
OldDockSite.DockManager.SetReplacingControl(nil);
end;
Result:=Control.ManualDock(NewDockSite,DropControl,ControlSide);
EnableAutoSizing;
end;
procedure TControl.AddHandlerOnResize(const OnResizeEvent: TNotifyEvent;
AsFirst: boolean);
begin
AddHandler(chtOnResize,TMethod(OnResizeEvent),AsFirst);
end;
procedure TControl.RemoveHandlerOnResize(const OnResizeEvent: TNotifyEvent);
begin
RemoveHandler(chtOnResize,TMethod(OnResizeEvent));
end;
procedure TControl.AddHandlerOnChangeBounds(
const OnChangeBoundsEvent: TNotifyEvent; AsFirst: boolean);
begin
AddHandler(chtOnChangeBounds,TMethod(OnChangeBoundsEvent),AsFirst);
end;
procedure TControl.RemoveHandlerOnChangeBounds(
const OnChangeBoundsEvent: TNotifyEvent);
begin
RemoveHandler(chtOnChangeBounds,TMethod(OnChangeBoundsEvent));
end;
procedure TControl.AddHandlerOnVisibleChanging(
const OnVisibleChangingEvent: TNotifyEvent; AsFirst: boolean);
begin
AddHandler(chtOnVisibleChanging,TMethod(OnVisibleChangingEvent),AsFirst);
end;
procedure TControl.RemoveHandlerOnVisibleChanging(
const OnVisibleChangingEvent: TNotifyEvent);
begin
RemoveHandler(chtOnVisibleChanging,TMethod(OnVisibleChangingEvent));
end;
procedure TControl.AddHandlerOnVisibleChanged(
const OnVisibleChangedEvent: TNotifyEvent; AsFirst: boolean);
begin
AddHandler(chtOnVisibleChanged,TMethod(OnVisibleChangedEvent),AsFirst);
end;
procedure TControl.RemoveHandlerOnVisibleChanged(
const OnVisibleChangedEvent: TNotifyEvent);
begin
RemoveHandler(chtOnVisibleChanged,TMethod(OnVisibleChangedEvent));
end;
procedure TControl.AddHandlerOnKeyDown(const OnKeyDownEvent: TKeyEvent;
AsFirst: boolean);
begin
AddHandler(chtOnKeyDown,TMethod(OnKeyDownEvent),AsFirst);
end;
procedure TControl.RemoveHandlerOnKeyDown(const OnKeyDownEvent: TKeyEvent);
begin
RemoveHandler(chtOnKeyDown,TMethod(OnKeyDownEvent));
end;
procedure TControl.RemoveAllHandlersOfObject(AnObject: TObject);
var
HandlerType: TControlHandlerType;
begin
inherited RemoveAllHandlersOfObject(AnObject);
for HandlerType:=Low(TControlHandlerType) to High(TControlHandlerType) do
FControlHandlers[HandlerType].RemoveAllMethodsOfObject(AnObject);
end;
{------------------------------------------------------------------------------
Method: TControl.GetTextBuf
Params: None
Returns: Nothing
Copies max bufsize-1 chars to buffer
------------------------------------------------------------------------------}
function TControl.GetTextBuf(Buffer: PChar; BufSize: Integer): Integer;
var
S: string;
begin
if BufSize <= 0 then Exit;
S := RealGetText;
if Length(S) >= BufSize
then begin
StrPLCopy(Buffer, S, BufSize - 1);
Result := BufSize - 1;
end
else begin
StrPCopy(Buffer, S);
Result := length(S);
end;
end;
{------------------------------------------------------------------------------
Method: TControl.SetTextBuf
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TControl.SetTextBuf(Buffer: PChar);
begin
RealSetText(Buffer);
end;
{------------------------------------------------------------------------------
TControl RealSetText
------------------------------------------------------------------------------}
procedure TControl.RealSetText(const Value: TCaption);
begin
if RealGetText = Value then Exit;
FCaption := Value;
Perform(CM_TEXTCHANGED, 0, 0);
end;
procedure TControl.TextChanged;
begin
end;
function TControl.GetCachedText(var CachedText: TCaption): boolean;
begin
CachedText := FCaption;
Result:= true;
end;
{------------------------------------------------------------------------------
TControl SetText
------------------------------------------------------------------------------}
procedure TControl.SetText(const Value: TCaption);
begin
//if CompareText(Name,'MainForm')=0 then debugln('TControl.SetText A ',DbgSName(Self),' GetText="',GetText,'" Value="',Value,'" FCaption="',FCaption,'"');
if GetText = Value then Exit;
// Check if SetTextBuf is overridden, otherwise
// we can call RealSetText directly
if TMethod(@Self.SetTextBuf).Code = Pointer(@TControl.SetTextBuf)
then begin
RealSetText(Value);
end
else begin
// Bummer, we have to do it the compatible way.
DebugLn('Note: SetTextBuf is overridden for: ', Classname);
SetTextBuf(PChar(Value));
end;
//if CompareText(ClassName,'TMEMO')=0 then
// debugln('TControl.SetText END ',DbgSName(Self),' FCaption="',FCaption,'"');
if HostDockSite <> nil then
HostDockSite.UpdateDockCaption(nil);
end;
{------------------------------------------------------------------------------
TControl Update
------------------------------------------------------------------------------}
procedure TControl.Update;
begin
if Parent<>nil then Parent.Update;
end;
{------------------------------------------------------------------------------
Method: TControl.Destroy
Params: None
Returns: Nothing
Destructor for the class.
------------------------------------------------------------------------------}
destructor TControl.Destroy;
var
HandlerType: TControlHandlerType;
Side: TAnchorKind;
i: Integer;
CurAnchorSide: TAnchorSide;
begin
//DebugLn('[TControl.Destroy] A ',Name,':',ClassName);
// make sure the capture is released
MouseCapture := False;
Application.ControlDestroyed(Self);
if (FHostDockSite <> nil) and not (csDestroying in FHostDockSite.ComponentState) then
begin
FHostDockSite.DoUndockClientMsg(nil, Self);
SetParent(nil);
Dock(nil, BoundsRect);
FHostDockSite := nil;
end else begin
if (FHostDockSite<>nil) and (FHostDockSite.FDockClients<>nil) then begin
FHostDockSite.FDockClients.Remove(Self);
FHostDockSite:=nil;
end;
SetParent(nil);
end;
if FAnchoredControls <> nil then
begin
for i := 0 to FAnchoredControls.Count - 1 do
for Side := Low(TAnchorKind) to High(TAnchorKind) do
begin
CurAnchorSide := AnchoredControls[i].AnchorSide[Side];
if (CurAnchorSide<>nil) and (CurAnchorSide.FControl = Self) then
CurAnchorSide.FControl := nil;
end;
FreeThenNil(FAnchoredControls);
end;
FreeThenNil(FActionLink);
for Side := Low(FAnchorSides) to High(FAnchorSides) do
FreeThenNil(FAnchorSides[Side]);
FreeThenNil(FBorderSpacing);
FreeThenNil(FConstraints);
FreeThenNil(FFont);
//DebugLn('[TControl.Destroy] B ',DbgSName(Self));
inherited Destroy;
//DebugLn('[TControl.Destroy] END ',DbgSName(Self));
for HandlerType := Low(TControlHandlerType) to High(TControlHandlerType) do
FreeThenNil(FControlHandlers[HandlerType]);
{$IFDEF DebugDisableAutoSizing}
FreeAndNil(FAutoSizingLockReasons);
{$ENDIF}
end;
{------------------------------------------------------------------------------
Method: TControl.Create
Params: None
Returns: Nothing
Constructor for the class.
------------------------------------------------------------------------------}
constructor TControl.Create(TheOwner: TComponent);
var
Side: TAnchorKind;
begin
DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.Create'){$ENDIF};
try
//if AnsiCompareText(ClassName,'TSpeedButton')=0 then
// DebugLn('TControl.Create START ',Name,':',ClassName);
inherited Create(TheOwner);
// no csOpaque: delphi compatible, win32 themes notebook depend on it
// csOpaque means entire client area will be drawn
// (most controls are semi-transparent)
FControlStyle := FControlStyle
+[csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks];
FConstraints:= TSizeConstraints.Create(Self);
FBorderSpacing := CreateControlBorderSpacing;
for Side:=Low(FAnchorSides) to High(FAnchorSides) do
FAnchorSides[Side]:=TAnchorSide.Create(Self,Side);
FAnchors := [akLeft,akTop];
FAlign := alNone;
FCaptureMouseButtons := [mbLeft];
FColor := clWindow;
FVisible := True;
FParentBidiMode := True;
FParentColor := True;
FParentFont := True;
FParentShowHint := True;
FWindowProc := @WndProc;
FCursor := crDefault;
FFont := TFont.Create;
FFont.OnChange := @FontChanged;
FIsControl := False;
FEnabled := True;
FHelpType := htContext;
FDragCursor := crDrag;
FFloatingDockSiteClass := TCustomDockForm;
//DebugLn('TControl.Create END ',Name,':',ClassName);
finally
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.Create'){$ENDIF};
end;
end;
{------------------------------------------------------------------------------
Method: TControl.CreateControlBorderSpacing
Params: None
Returns: ControlBorderSpacing instance
Creates the default ControlBorderSpacing. Allowes descendant controls to overide
this.
------------------------------------------------------------------------------}
function TControl.CreateControlBorderSpacing: TControlBorderSpacing;
begin
Result := TControlBorderSpacing.Create(Self);
end;
{------------------------------------------------------------------------------
Method: TControl.GetDeviceContext
Params: WindowHandle: the windowhandle of this control
Returns: a Devicecontext
Get the devicecontext of the parent Wincontrol for this Control.
------------------------------------------------------------------------------}
function TControl.GetDeviceContext(var WindowHandle: HWnd): HDC;
begin
if Parent = nil
then raise EInvalidOperation.CreateFmt('Control ''%s'' has no parent window', [Name]);
Result := Parent.GetDeviceContext(WindowHandle);
MoveWindowOrgEx(Result, Left, Top);
IntersectClipRect(Result, 0, 0, Width, Height);
end;
{------------------------------------------------------------------------------
Method: TControl.HasParent
Params:
Returns: True - the item has a parent responsible for streaming
This function will be called during streaming to decide if a component has
to be streamed by it's owner or parent.
------------------------------------------------------------------------------}
function TControl.HasParent : Boolean;
begin
Result := (FParent <> nil);
end;
function TControl.GetParentComponent: TComponent;
begin
Result := Parent;
end;
{------------------------------------------------------------------------------
function TControl.IsParentOf(AControl: TControl): boolean;
------------------------------------------------------------------------------}
function TControl.IsParentOf(AControl: TControl): boolean;
begin
Result:=false;
while AControl<>nil do begin
AControl:=AControl.Parent;
if Self=AControl then begin
Result:=true;
exit;
end;
end;
end;
function TControl.GetTopParent: TControl;
begin
Result:=Self;
while Result.Parent<>nil do
Result:=Result.Parent;
end;
{------------------------------------------------------------------------------
Method: TControl.SendToBack
Params: None
Returns: Nothing
Puts a control back in Z-order behind all other controls
------------------------------------------------------------------------------}
procedure TControl.SendToBack;
begin
SetZOrder(false);
end;
{------------------------------------------------------------------------------
procedure TControl.AnchorToNeighbour(Side: TAnchorKind; Space: integer;
Sibling: TControl);
Setup AnchorSide to anchor one side to the side of a neighbour sibling.
For example Right side to Left side, or Top side to Bottom.
------------------------------------------------------------------------------}
procedure TControl.AnchorToNeighbour(Side: TAnchorKind; Space: integer;
Sibling: TControl);
begin
if Parent<>nil then Parent.DisableAlign;
try
case Side of
akLeft: BorderSpacing.Left:=Space;
akTop: BorderSpacing.Top:=Space;
akRight: BorderSpacing.Right:=Space;
akBottom: BorderSpacing.Bottom:=Space;
end;
AnchorSide[Side].Side:=DefaultSideForAnchorKind[Side];
AnchorSide[Side].Control:=Sibling;
Anchors:=Anchors+[Side];
finally
if Parent<>nil then Parent.EnableAlign;
end;
end;
procedure TControl.AnchorParallel(Side: TAnchorKind; Space: integer;
Sibling: TControl);
begin
if Parent<>nil then Parent.DisableAlign;
try
case Side of
akLeft: BorderSpacing.Left:=Space;
akTop: BorderSpacing.Top:=Space;
akRight: BorderSpacing.Right:=Space;
akBottom: BorderSpacing.Bottom:=Space;
end;
case Side of
akLeft: AnchorSide[Side].Side:=asrLeft;
akTop: AnchorSide[Side].Side:=asrTop;
akRight: AnchorSide[Side].Side:=asrRight;
akBottom: AnchorSide[Side].Side:=asrBottom;
end;
AnchorSide[Side].Control:=Sibling;
Anchors:=Anchors+[Side];
finally
if Parent<>nil then Parent.EnableAlign;
end;
end;
{------------------------------------------------------------------------------
procedure TControl.AnchorHorizontalCenterTo(Sibling: TControl);
Setup AnchorSide to center the control horizontally relative to a sibling.
------------------------------------------------------------------------------}
procedure TControl.AnchorHorizontalCenterTo(Sibling: TControl);
begin
if Parent<>nil then Parent.DisableAlign;
try
AnchorSide[akLeft].Side:=asrCenter;
AnchorSide[akLeft].Control:=Sibling;
Anchors:=Anchors+[akLeft]-[akRight];
finally
if Parent<>nil then Parent.EnableAlign;
end;
end;
{------------------------------------------------------------------------------
procedure TControl.AnchorVerticalCenterTo(Sibling: TControl);
Setup AnchorSide to center the control vertically relative to a sibling.
------------------------------------------------------------------------------}
procedure TControl.AnchorVerticalCenterTo(Sibling: TControl);
begin
if Parent<>nil then Parent.DisableAlign;
try
AnchorSide[akTop].Side:=asrCenter;
AnchorSide[akTop].Control:=Sibling;
Anchors:=Anchors+[akTop]-[akBottom];
finally
if Parent<>nil then Parent.EnableAlign;
end;
end;
procedure TControl.AnchorToCompanion(Side: TAnchorKind; Space: integer;
Sibling: TControl; FreeCompositeSide: boolean);
procedure AnchorCompanionSides(
ResizeSide,// the side of this control, where Sibling is touched and moved
OppositeResizeSide, // opposite of ResizeSide
FixedSide1,// the first non moving side
FixedSide2:// the second non moving side
TAnchorKind);
begin
if not (OppositeAnchor[Side] in Anchors) then
AnchorSide[OppositeResizeSide].Control:=nil;
AnchorToNeighbour(ResizeSide,Space,Sibling);
AnchorParallel(FixedSide1,0,Sibling);
AnchorParallel(FixedSide2,0,Sibling);
end;
var
NewAnchors: TAnchors;
begin
if Parent<>nil then Parent.DisableAlign;
try
// anchor all. Except for the opposite side.
NewAnchors:=[akLeft,akTop,akRight,akBottom];
if FreeCompositeSide or (not (OppositeAnchor[Side] in Anchors)) then
Exclude(NewAnchors,OppositeAnchor[Side]);
Anchors:=NewAnchors;
case Side of
akLeft: AnchorCompanionSides(akLeft,akRight,akTop,akBottom);
akRight: AnchorCompanionSides(akRight,akLeft,akTop,akBottom);
akTop: AnchorCompanionSides(akTop,akBottom,akLeft,akRight);
akBottom: AnchorCompanionSides(akBottom,akTop,akLeft,akRight);
end;
finally
if Parent<>nil then Parent.EnableAlign;
end;
end;
procedure TControl.AnchorSame(Side: TAnchorKind; Sibling: TControl);
begin
if Parent<>nil then Parent.DisableAlign;
try
if Side in Sibling.Anchors then
Anchors:=Anchors+[Side]
else
Anchors:=Anchors-[Side];
AnchorSide[Side].Assign(Sibling.AnchorSide[Side]);
finally
if Parent<>nil then Parent.EnableAlign;
end;
end;
procedure TControl.AnchorAsAlign(TheAlign: TAlign; Space: Integer);
begin
Parent.DisableAlign;
try
if akLeft in AnchorAlign[TheAlign] then begin
BorderSpacing.Left:=Space;
AnchorSide[akLeft].Side:=asrLeft;
AnchorSide[akLeft].Control:=Parent;
end;
if akTop in AnchorAlign[TheAlign] then begin
BorderSpacing.Top:=Space;
AnchorSide[akTop].Side:=asrTop;
AnchorSide[akTop].Control:=Parent;
end;
if akRight in AnchorAlign[TheAlign] then begin
BorderSpacing.Right:=Space;
AnchorSide[akRight].Side:=asrRight;
AnchorSide[akRight].Control:=Parent;
end;
if akBottom in AnchorAlign[TheAlign] then begin
BorderSpacing.Bottom:=Space;
AnchorSide[akBottom].Side:=asrBottom;
AnchorSide[akBottom].Control:=Parent;
end;
Anchors:=Anchors+AnchorAlign[TheAlign];
finally
Parent.EnableAlign;
end;
end;
procedure TControl.AnchorClient(Space: Integer);
begin
AnchorAsAlign(alClient,Space);
end;
function TControl.AnchoredControlCount: integer;
begin
if FAnchoredControls = nil then
Result := 0
else
Result := FAnchoredControls.Count;
end;
procedure TControl.SetInitialBounds(aLeft, aTop, aWidth, aHeight: integer);
begin
//DebugLn('TControl.SetInitialBounds A ',Name,':',ClassName,' ',aLeft,',',aTop,',',aWidth,',',aHeight);
if (csLoading in ComponentState)
or ((Owner<>nil) and (csLoading in Owner.ComponentState)) then
exit;
//DebugLn('TControl.SetInitialBounds B ',Name,':',ClassName,' ',aLeft,',',aTop,',',aWidth,',',aHeight);
SetBounds(aLeft,aTop,aWidth,aHeight);
end;
procedure TControl.SetBoundsKeepBase(aLeft, aTop, aWidth, aHeight: integer);
begin
ChangeBounds(aLeft, aTop, aWidth, aHeight, true);
end;
{------------------------------------------------------------------------------
procedure TControl.GetPreferredSize(
var PreferredWidth, PreferredHeight: integer; Raw: boolean;
WithThemeSpace: Boolean);
Returns the default/preferred width and height for a control, which is used
by the LCL autosizing algorithms as default size. Only positive values are
valid. Negative or 0 are treated as undefined and the LCL uses other sizes
instead.
Raw: If not Raw then the values will be adjusted by the constraints and
undefined values will be replaced by GetDefaultWidth/GetDefaultHeight.
WithThemeSpace: If true, adds space for stacking. For example: TRadioButton
has a minimum size. But for stacking multiple TRadioButtons there should be
some space around. This space is theme dependent, so it passed parameter to
the widgetset.
TWinControl overrides this and asks the interface for theme dependent values.
See TWinControl.GetPreferredSize for more information.
------------------------------------------------------------------------------}
procedure TControl.GetPreferredSize(var PreferredWidth,
PreferredHeight: integer; Raw: boolean; WithThemeSpace: boolean);
begin
if WithThemeSpace then begin
if not (cfPreferredSizeValid in FControlFlags) then begin
CalculatePreferredSize(FPreferredWidth,FPreferredHeight,true);
Include(FControlFlags,cfPreferredSizeValid);
end;
PreferredWidth:=FPreferredWidth;
PreferredHeight:=FPreferredHeight;
end else begin
if not (cfPreferredMinSizeValid in FControlFlags) then begin
CalculatePreferredSize(FPreferredMinWidth,FPreferredMinHeight,false);
Include(FControlFlags,cfPreferredMinSizeValid);
end;
PreferredWidth:=FPreferredMinWidth;
PreferredHeight:=FPreferredMinHeight;
end;
if not Raw then begin
// use defaults for undefined preferred size
if (PreferredWidth<0)
or ((PreferredWidth=0) and (not (csAutoSize0x0 in ControlStyle))) then begin
if AutoSize or WidthIsAnchored then
PreferredWidth:=GetDefaultWidth
else
PreferredWidth:=Width;
end;
if (PreferredHeight<0)
or ((PreferredHeight=0) and (not (csAutoSize0x0 in ControlStyle))) then begin
if AutoSize or HeightIsAnchored then
PreferredHeight:=GetDefaultHeight
else
PreferredHeight:=Height;
end;
// apply constraints
PreferredWidth:=Constraints.MinMaxWidth(PreferredWidth);
PreferredHeight:=Constraints.MinMaxHeight(PreferredHeight);
end;
end;
{------------------------------------------------------------------------------
function TControl.GetDefaultWidth: integer;
The default width for this control independent of any calculated values
like Width and GetPreferredSize.
------------------------------------------------------------------------------}
function TControl.GetDefaultWidth: integer;
begin
if WidthIsAnchored then
// if width is anchored the read and base bounds were changed at designtime
Result := GetControlClassDefaultSize.cx
else if cfBaseBoundsValid in FControlFlags then
Result := FBaseBounds.Right - FBaseBounds.Left
else
if cfWidthLoaded in FControlFlags then
Result := FReadBounds.Right - FReadBounds.Left
else
Result := GetControlClassDefaultSize.cx;
end;
{------------------------------------------------------------------------------
function TControl.GetDefaultHeight: integer;
The default height for this control independent of any calculated values
like Height and GetPreferredSize.
------------------------------------------------------------------------------}
function TControl.GetDefaultHeight: integer;
begin
if HeightIsAnchored then
// if height is anchored the read and base bounds were changed at designtime
Result := GetControlClassDefaultSize.cy
else if cfBaseBoundsValid in FControlFlags then
Result := BaseBounds.Bottom - BaseBounds.Top
else
if cfHeightLoaded in FControlFlags then
Result := FReadBounds.Bottom - FReadBounds.Top
else
Result := GetControlClassDefaultSize.CY;
end;
{------------------------------------------------------------------------------
class function TControl.GetControlClassDefaultSize: TPoint;
The default size of this type of controls.
Used by GetDefaultWidth and GetDefaultHeight.
------------------------------------------------------------------------------}
class function TControl.GetControlClassDefaultSize: TSize;
begin
Result.CX := 75;
Result.CY := 50;
end;
{------------------------------------------------------------------------------
procedure TControl.CNPreferredSizeChanged;
Utility function to retrieve Left,Top,Right and Bottom.
------------------------------------------------------------------------------}
function TControl.GetSidePosition(Side: TAnchorKind): integer;
begin
case Side of
akLeft: Result := Left;
akTop: Result := Top;
akRight: Result := Left + Width;
akBottom: Result := Top + Height;
end;
end;
{------------------------------------------------------------------------------
procedure TControl.CNPreferredSizeChanged;
Called by the LCL interface, when something changed that effects the result
of the interface values for GetPreferredSize.
------------------------------------------------------------------------------}
procedure TControl.CNPreferredSizeChanged;
begin
InvalidatePreferredSize;
end;
{------------------------------------------------------------------------------
procedure TControl.InvalidatePreferredSize;
Invalidate the cache of the preferred size of this and all parent controls.
------------------------------------------------------------------------------}
procedure TControl.InvalidatePreferredSize;
var
AControl: TControl;
begin
AControl:=Self;
while AControl<>nil do begin
Exclude(AControl.FControlFlags,cfPreferredSizeValid);
Exclude(AControl.FControlFlags,cfPreferredMinSizeValid);
if AControl is TWinControl then
Exclude(TWinControl(AControl).FWinControlFlags,wcfAdjustedLogicalClientRectValid);
if not AControl.IsControlVisible then break;
AControl:=AControl.Parent;
end;
end;
function TControl.GetAnchorsDependingOnParent(WithNormalAnchors: Boolean
): TAnchors;
var
a: TAnchorKind;
begin
Result:=[];
if Parent=nil then exit;
if (Anchors*[akLeft,akRight]=[]) then begin
// center horizontally
Result:=Result+[akLeft,akRight];
end;
if (Anchors*[akTop,akBottom]=[]) then begin
// center vertically
Result:=Result+[akTop,akBottom];
end;
for a:=Low(TAnchorKind) to High(TAnchorKind) do begin
if (a in (Anchors+AnchorAlign[Align])) then begin
if WithNormalAnchors
or (AnchorSide[a].Control=Parent)
or ((AnchorSide[a].Control=nil) and (a in [akRight,akBottom])) then begin
// side anchored
Include(Result,a);
end;
end;
end;
end;
procedure TControl.DisableAutoSizing
{$IFDEF DebugDisableAutoSizing}(const Reason: string){$ENDIF};
begin
inc(FAutoSizingLockCount);
{$IFDEF DebugDisableAutoSizing}
if FAutoSizingLockReasons=nil then FAutoSizingLockReasons:=TStringList.Create;
FAutoSizingLockReasons.Add(Reason);
{$ENDIF}
//DebugLn([Space(FAutoSizingLockCount*2),'TControl.DisableAutoSizing ',DbgSName(Self),' ',FAutoSizingLockCount]);
if FAutoSizingLockCount=1 then
begin
if Parent<>nil then
begin
//DebugLn([Space(FAutoSizingLockCount*2),'TControl.DisableAutoSizing ',DbgSName(Self),' disable Parent=',DbgSName(Parent)]);
Parent.DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.DisableAutoSizing'){$ENDIF};
end;
end;
end;
procedure TControl.EnableAutoSizing
{$IFDEF DebugDisableAutoSizing}(const Reason: string){$ENDIF};
{$IFDEF DebugDisableAutoSizing}
procedure CheckReason;
var
i: Integer;
begin
i:=FAutoSizingLockReasons.Count-1;
while i>=0 do begin
if FAutoSizingLockReasons[i]=Reason then begin
FAutoSizingLockReasons.Delete(i);
exit;
end;
dec(i);
end;
RaiseGDBException('TControl.EnableAutoSizing never disabled with reason: '+Reason);
end;
{$ENDIF}
begin
{$IFDEF DebugDisableAutoSizing}
CheckReason;
{$ENDIF}
if FAutoSizingLockCount<=0 then
raise Exception.Create('TControl.EnableAutoSizing '+DbgSName(Self)+': missing DisableAutoSizing');
dec(FAutoSizingLockCount);
//DebugLn([Space(FAutoSizingLockCount*2),'TControl.EnableAutoSizing ',DbgSName(Self),' ',FAutoSizingLockCount]);
if (FAutoSizingLockCount=0) then
begin
if (Parent<>nil) then
begin
//DebugLn([Space(FAutoSizingLockCount*2),'TControl.EnableAutoSizing ',DbgSName(Self),' enable Parent ',DbgSName(Parent)]);
Parent.EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.DisableAutoSizing'){$ENDIF};
end else
DoAllAutoSize;
end;
end;
{$IFDEF DebugDisableAutoSizing}
procedure TControl.WriteAutoSizeReasons(NotIfEmpty: boolean);
begin
if NotIfEmpty and (FAutoSizingLockReasons.Count=0) then exit;
DebugLn(['TControl.WriteAutoSizeReasons ',DbgSName(Self)]);
debugln(FAutoSizingLockReasons.Text);
end;
{$ENDIF}
procedure TControl.EndAutoSizing;
procedure Error;
begin
RaiseGDBException('TControl.EndAutoSizing');
end;
begin
if not FAutoSizingSelf then Error;
FAutoSizingSelf := False;
end;
{------------------------------------------------------------------------------
Method: TControl.WMWindowPosChanged
Params: Msg: The message
Returns: nothing
event handler.
------------------------------------------------------------------------------}
procedure TControl.WMWindowPosChanged(var Message: TLMWindowPosChanged);
begin
// Do not handle this message and leave it to WMSize and WMMove
Message.Result := 0;
end;
{------------------------------------------------------------------------------
Method: TControl.WMSize
Params: Message : TLMSize
Returns: nothing
Event handler for LMSize messages.
Overriden by TWinControl.WMSize.
------------------------------------------------------------------------------}
procedure TControl.WMSize(var Message : TLMSize);
begin
{$IFDEF CHECK_POSITION}
if CheckPosition(Self) then
DebugLn('[TControl.WMSize] Name=',Name,':',ClassName,' Message.Width=',DbgS(Message.Width),' Message.Height=',DbgS(Message.Height),' Width=',DbgS(Width),' Height=',DbgS(Height));
{$ENDIF}
//Assert(False, Format('Trace:[TWinControl.WMSize] %s', [ClassName]));
if Parent<>nil then
SetBoundsKeepBase(Left,Top,Message.Width,Message.Height)
else
SetBounds(Left,Top,Message.Width,Message.Height);
end;
{------------------------------------------------------------------------------
Method: TControl.WMMove
Params: Msg: The message
Returns: nothing
event handler.
Message.MoveType=0 is the default, all other values will force a RequestAlign.
------------------------------------------------------------------------------}
procedure TControl.WMMove(var Message: TLMMove);
begin
{$IFDEF CHECK_POSITION}
if CheckPosition(Self) then
DebugLn('[TControl.WMMove] Name=',Name,':',ClassName,' Message.XPos=',DbgS(Message.XPos),' Message.YPos=',DbgS(Message.YPos),' OldLeft=',DbgS(Left),' OldTop=',DbgS(Top));
{$ENDIF}
// Just sync the coordinates
if Parent<>nil then
SetBoundsKeepBase(Message.XPos, Message.YPos, Width, Height)
else
SetBounds(Message.XPos, Message.YPos, Width, Height);
end;
{------------------------------------------------------------------------------
Method: TControl.SetBiDiMode
------------------------------------------------------------------------------}
procedure TControl.SetBiDiMode(AValue: TBiDiMode);
begin
if FBiDiMode=AValue then exit;
FBiDiMode:=AValue;
FParentBiDiMode := False;
DisableAutoSizing;
try
Perform(CM_BIDIMODECHANGED, 0, 0); // see TWinControl.CMBiDiModeChanged
finally
EnableAutoSizing;
end;
end;
{------------------------------------------------------------------------------
Method: TControl.SetParentBiDiMode
------------------------------------------------------------------------------}
procedure TControl.SetParentBiDiMode(AValue: Boolean);
begin
if FParentBiDiMode = AValue then Exit;
FParentBiDiMode := AValue;
if (FParent <> nil) and not (csReading in ComponentState) then
Perform(CM_PARENTBIDIMODECHANGED, 0, 0);
end;
{------------------------------------------------------------------------------
Method: TControl.CMBiDiModeChanged
------------------------------------------------------------------------------}
procedure TControl.CMBiDiModeChanged(var Message: TLMessage);
begin
if (Message.wParam = 0) then
Invalidate;
end;
{------------------------------------------------------------------------------
TControl.CMParentBidiModeChanged
assumes: FParent <> nil
------------------------------------------------------------------------------}
procedure TControl.CMParentBidiModeChanged(var Message: TLMessage);
begin
if csLoading in ComponentState then exit;
if ParentBidiMode then
begin
BidiMode := FParent.BidiMode;
FParentBiDiMode := True;
end;
end;
{------------------------------------------------------------------------------
TControl.IsBiDiModeStored
------------------------------------------------------------------------------}
function TControl.IsBiDiModeStored: boolean;
begin
Result := not ParentBidiMode;
end;
{------------------------------------------------------------------------------
TControl.IsRightToLeft
------------------------------------------------------------------------------}
function TControl.IsRightToLeft: Boolean;
begin
Result := UseRightToLeftReading;
end;
{------------------------------------------------------------------------------
TControl.UseRightToLeftAlignment
------------------------------------------------------------------------------}
function TControl.UseRightToLeftAlignment: Boolean;
begin
Result := (BiDiMode = bdRightToLeft);
end;
{------------------------------------------------------------------------------
TControl.UseRightToLeftReading
------------------------------------------------------------------------------}
function TControl.UseRightToLeftReading: Boolean;
begin
Result := (BiDiMode <> bdLeftToRight);
end;
{------------------------------------------------------------------------------
TControl.UseRightToLeftScrollBar
------------------------------------------------------------------------------}
function TControl.UseRightToLeftScrollBar: Boolean;
begin
Result := (BiDiMode in [bdRightToLeft, bdRightToLeftNoAlign]);
end;
{$IFDEF ASSERT_IS_ON}
{$UNDEF ASSERT_IS_ON}
{$C-}
{$ENDIF}
// included by controls.pp
Reference in New Issue View Git Blame Copy Permalink