mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-06 00:18:08 +02:00
d070dd6b88
fix for TControl.GetDefaultColor never recursing up to parent as it should. looks like the original code was 'mangled' by a bad cut-and-paste a number of years back.
6053 lines
194 KiB
PHP
6053 lines
194 KiB
PHP
{%MainUnit ../controls.pp}
|
|
|
|
{******************************************************************************
|
|
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 license.
|
|
*****************************************************************************
|
|
}
|
|
|
|
{$IFOPT C-}
|
|
// Uncomment for local trace
|
|
// {$C+}
|
|
// {$DEFINE ASSERT_IS_ON}
|
|
{$ENDIF}
|
|
|
|
{ $DEFINE CHECK_POSITION}
|
|
|
|
{ TLazAccessibleObjectEnumerator }
|
|
|
|
function TLazAccessibleObjectEnumerator.GetCurrent: TLazAccessibleObject;
|
|
begin
|
|
if Assigned(FCurrent) then
|
|
Result:=TLazAccessibleObject(FCurrent.Data)
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
{ TLazAccessibleObject }
|
|
|
|
function TLazAccessibleObject.GetHandle: PtrInt;
|
|
var
|
|
WidgetsetClass: TWSLazAccessibleObjectClass;
|
|
begin
|
|
WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
|
|
if (WidgetsetClass <> nil) and (FHandle = 0) then
|
|
begin
|
|
FHandle := WidgetsetClass.CreateHandle(Self);
|
|
if FHandle <> 0 then
|
|
InitializeHandle();
|
|
end;
|
|
Result := FHandle;
|
|
end;
|
|
|
|
function TLazAccessibleObject.GetAccessibleValue: TCaption;
|
|
begin
|
|
Result := FAccessibleValue;
|
|
end;
|
|
|
|
function TLazAccessibleObject.GetPosition: TPoint;
|
|
begin
|
|
if (OwnerControl <> nil) and (OwnerControl.GetAccessibleObject() = Self) then
|
|
begin
|
|
Result := Point(OwnerControl.Left, OwnerControl.Top);
|
|
Exit;
|
|
end;
|
|
Result := FPosition;
|
|
end;
|
|
|
|
function TLazAccessibleObject.GetSize: TSize;
|
|
begin
|
|
if (OwnerControl <> nil) and (OwnerControl.GetAccessibleObject() = Self) then
|
|
begin
|
|
Result := Types.Size(OwnerControl.Width, OwnerControl.Height);
|
|
Exit;
|
|
end;
|
|
Result := FSize;
|
|
end;
|
|
|
|
procedure TLazAccessibleObject.SetHandle(AValue: PtrInt);
|
|
begin
|
|
if AValue = FHandle then Exit;
|
|
FHandle := AValue;
|
|
if FHandle <> 0 then
|
|
InitializeHandle();
|
|
end;
|
|
|
|
procedure TLazAccessibleObject.SetPosition(AValue: TPoint);
|
|
var
|
|
WidgetsetClass: TWSLazAccessibleObjectClass;
|
|
begin
|
|
if (FPosition.X=AValue.X) and (FPosition.Y=AValue.Y) then Exit;
|
|
FPosition := AValue;
|
|
WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
|
|
WidgetsetClass.SetPosition(Self, AValue);
|
|
end;
|
|
|
|
procedure TLazAccessibleObject.SetSize(AValue: TSize);
|
|
var
|
|
WidgetsetClass: TWSLazAccessibleObjectClass;
|
|
begin
|
|
if (FSize.CX=AValue.CX) and (FSize.CY=AValue.CY) then Exit;
|
|
FSize := AValue;
|
|
WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
|
|
WidgetsetClass.SetSize(Self, AValue);
|
|
end;
|
|
|
|
class procedure TLazAccessibleObject.WSRegisterClass;
|
|
begin
|
|
// inherited WSRegisterClass;
|
|
RegisterLazAccessibleObject;
|
|
end;
|
|
|
|
constructor TLazAccessibleObject.Create(AOwner: TControl);
|
|
begin
|
|
inherited Create;//(AOwner);
|
|
OwnerControl := AOwner;
|
|
FChildrenSortedForDataObject := TAvlTree.Create(@CompareLazAccessibleObjectsByDataObject);
|
|
WSRegisterClass();
|
|
end;
|
|
|
|
destructor TLazAccessibleObject.Destroy;
|
|
var
|
|
WidgetsetClass: TWSLazAccessibleObjectClass;
|
|
begin
|
|
WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
|
|
ClearChildAccessibleObjects();
|
|
if (WidgetsetClass <> nil) and (FHandle <> 0) then
|
|
WidgetsetClass.DestroyHandle(Self);
|
|
if Assigned(Parent) then
|
|
Parent.RemoveChildAccessibleObject(self, False);
|
|
FreeAndNil(FChildrenSortedForDataObject);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TLazAccessibleObject.HandleAllocated: Boolean;
|
|
begin
|
|
Result := FHandle <> 0;
|
|
end;
|
|
|
|
procedure TLazAccessibleObject.InitializeHandle;
|
|
var
|
|
WidgetsetClass: TWSLazAccessibleObjectClass;
|
|
begin
|
|
WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
|
|
WidgetsetClass.SetAccessibleName(Self, FAccessibleName);
|
|
WidgetsetClass.SetAccessibleDescription(Self, FAccessibleDescription);
|
|
WidgetsetClass.SetAccessibleValue(Self, FAccessibleValue);
|
|
WidgetsetClass.SetAccessibleRole(Self, FAccessibleRole);
|
|
end;
|
|
|
|
procedure TLazAccessibleObject.SetAccessibleName(const AName: TCaption);
|
|
var
|
|
WidgetsetClass: TWSLazAccessibleObjectClass;
|
|
begin
|
|
if FAccessibleName=AName then Exit;
|
|
FAccessibleName := AName;
|
|
WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
|
|
WidgetsetClass.SetAccessibleName(Self, AName);
|
|
end;
|
|
|
|
procedure TLazAccessibleObject.SetAccessibleDescription(const ADescription: TCaption);
|
|
var
|
|
WidgetsetClass: TWSLazAccessibleObjectClass;
|
|
begin
|
|
if FAccessibleDescription=ADescription then Exit;
|
|
FAccessibleDescription := ADescription;
|
|
WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
|
|
WidgetsetClass.SetAccessibleDescription(Self, ADescription);
|
|
end;
|
|
|
|
procedure TLazAccessibleObject.SetAccessibleValue(const AValue: TCaption);
|
|
var
|
|
WidgetsetClass: TWSLazAccessibleObjectClass;
|
|
begin
|
|
if FAccessibleValue=AValue then Exit;
|
|
FAccessibleValue := AValue;
|
|
WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
|
|
WidgetsetClass.SetAccessibleValue(Self, AValue);
|
|
end;
|
|
|
|
procedure TLazAccessibleObject.SetAccessibleRole(const ARole: TLazAccessibilityRole);
|
|
var
|
|
WidgetsetClass: TWSLazAccessibleObjectClass;
|
|
begin
|
|
if FAccessibleRole=ARole then Exit;
|
|
FAccessibleRole := ARole;
|
|
WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
|
|
WidgetsetClass.SetAccessibleRole(Self, ARole);
|
|
end;
|
|
|
|
function TLazAccessibleObject.FindOwnerWinControl: TWinControl;
|
|
begin
|
|
Result := nil;
|
|
if OwnerControl is TWinControl then Exit(TWinControl(OwnerControl));
|
|
if OwnerControl is TControl then Exit(OwnerControl.Parent);
|
|
if Self.Parent = nil then Exit;
|
|
Result := Self.Parent.FindOwnerWinControl();
|
|
end;
|
|
|
|
function TLazAccessibleObject.AddChildAccessibleObject(
|
|
ADataObject: TObject = nil): TLazAccessibleObject;begin
|
|
Result := nil;
|
|
if FChildrenSortedForDataObject = nil then Exit;
|
|
if (ADataObject <> nil) then begin
|
|
Result := GetChildAccessibleObjectWithDataObject(ADataObject);
|
|
if Result <> nil then
|
|
Exit;
|
|
end;
|
|
Result := TLazAccessibleObject.Create(OwnerControl);
|
|
Result.Parent := Self;
|
|
Result.DataObject := ADataObject;
|
|
FChildrenSortedForDataObject.Add(Result);
|
|
//DebugLn('[TControl.AddChildAccessibleObject] Name=%s', [Name]);
|
|
end;
|
|
|
|
procedure TLazAccessibleObject.InsertChildAccessibleObject(
|
|
AObject: TLazAccessibleObject);
|
|
begin
|
|
if FChildrenSortedForDataObject = nil then Exit;
|
|
if (AObject.Parent <> nil) and (AObject.Parent <> Self) then
|
|
AObject.Parent.RemoveChildAccessibleObject(AObject, False);
|
|
AObject.Parent := Self;
|
|
if (FChildrenSortedForDataObject.Find(AObject) <> nil) then exit;
|
|
FChildrenSortedForDataObject.Add(AObject);
|
|
end;
|
|
|
|
procedure TLazAccessibleObject.ClearChildAccessibleObjects;
|
|
var
|
|
lXObject: TLazAccessibleObject;
|
|
AVLNode: TAvlTreeNode;
|
|
begin
|
|
if FChildrenSortedForDataObject = nil then Exit;
|
|
//DebugLn(Format('[TControl.ClearChildAccessibleObjects] Name=%s Count=%d', [Name, FAccessibleChildren.Count]));
|
|
// Free only the non-control children
|
|
AVLNode:=FChildrenSortedForDataObject.FindLowest;
|
|
while AVLNode<>nil do begin
|
|
lXObject := TLazAccessibleObject(AVLNode.Data);
|
|
if lXObject.OwnerControl = OwnerControl then begin
|
|
lXObject.Parent := nil; // Clear parent so .Free doesn't recurse
|
|
lXObject.Free;
|
|
end;
|
|
AVLNode:=FChildrenSortedForDataObject.FindSuccessor(AVLNode);
|
|
end;
|
|
FChildrenSortedForDataObject.Clear;
|
|
end;
|
|
|
|
procedure TLazAccessibleObject.RemoveChildAccessibleObject(
|
|
AObject: TLazAccessibleObject; AFreeObject: Boolean = True);
|
|
var
|
|
Node: TAvlTreeNode;
|
|
begin
|
|
if FChildrenSortedForDataObject = nil then Exit;
|
|
if Assigned(AObject.Parent) then
|
|
AObject.Parent := nil;
|
|
Node:=FChildrenSortedForDataObject.Find(AObject);
|
|
if Node=nil then exit;
|
|
FChildrenSortedForDataObject.Delete(Node);
|
|
if AFreeObject then
|
|
AObject.Free;
|
|
end;
|
|
|
|
function TLazAccessibleObject.GetChildAccessibleObjectWithDataObject(
|
|
ADataObject: TObject): TLazAccessibleObject;
|
|
var
|
|
Node: TAvlTreeNode;
|
|
begin
|
|
Result := nil;
|
|
if FChildrenSortedForDataObject = nil then Exit;
|
|
Node:=FChildrenSortedForDataObject.FindKey(ADataObject,@CompareDataObjectWithLazAccessibleObject);
|
|
if Node<>nil then
|
|
Result:=TLazAccessibleObject(Node.Data);
|
|
end;
|
|
|
|
function TLazAccessibleObject.GetChildAccessibleObjectsCount: Integer;
|
|
begin
|
|
Result := 0;
|
|
if FChildrenSortedForDataObject <> nil then
|
|
Result := FChildrenSortedForDataObject.Count;
|
|
end;
|
|
|
|
function TLazAccessibleObject.GetChildAccessibleObject(AIndex: Integer): TLazAccessibleObject;
|
|
var
|
|
lNode: TAvlTreeNode = nil;
|
|
begin
|
|
Result := nil;
|
|
if AIndex = 0 then lNode := FChildrenSortedForDataObject.FindLowest()
|
|
else if AIndex = GetChildAccessibleObjectsCount()-1 then
|
|
lNode := FChildrenSortedForDataObject.FindHighest()
|
|
else if AIndex = FLastSearchIndex then lNode := FLastSearchNode
|
|
else if AIndex = FLastSearchIndex+1 then
|
|
lNode := FChildrenSortedForDataObject.FindSuccessor(FLastSearchNode)
|
|
else if AIndex = FLastSearchIndex-1 then
|
|
lNode := FChildrenSortedForDataObject.FindPrecessor(FLastSearchNode);
|
|
|
|
FLastSearchIndex := AIndex;
|
|
FLastSearchNode := lNode;
|
|
|
|
if lNode = nil then Exit;
|
|
|
|
Result := TLazAccessibleObject(lNode.Data);
|
|
end;
|
|
|
|
function TLazAccessibleObject.GetFirstChildAccessibleObject: TLazAccessibleObject;
|
|
begin
|
|
Result := nil;
|
|
FLastSearchInSubcontrols := False;
|
|
if GetChildAccessibleObjectsCount() > 0 then
|
|
Result := GetChildAccessibleObject(0)
|
|
else if OwnerControl is TWinControl then
|
|
begin
|
|
FLastSearchIndex := 1;
|
|
FLastSearchInSubcontrols := True;
|
|
if (TWinControl(OwnerControl).ControlCount > 0) then
|
|
Result := TWinControl(OwnerControl).Controls[0].GetAccessibleObject();
|
|
end;
|
|
end;
|
|
|
|
function TLazAccessibleObject.GetNextChildAccessibleObject: TLazAccessibleObject;
|
|
begin
|
|
Result := nil;
|
|
if not FLastSearchInSubcontrols then
|
|
begin
|
|
if FLastSearchIndex < GetChildAccessibleObjectsCount() then
|
|
Result := GetChildAccessibleObject(FLastSearchIndex + 1)
|
|
else if OwnerControl is TWinControl then
|
|
begin
|
|
FLastSearchIndex := 1;
|
|
FLastSearchInSubcontrols := True;
|
|
if (TWinControl(OwnerControl).ControlCount > 0) then
|
|
Result := TWinControl(OwnerControl).Controls[0].GetAccessibleObject();
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if TWinControl(OwnerControl).ControlCount > FLastSearchIndex then
|
|
begin
|
|
Result := TWinControl(OwnerControl).Controls[FLastSearchIndex].GetAccessibleObject();
|
|
Inc(FLastSearchIndex);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TLazAccessibleObject.GetSelectedChildAccessibleObject: TLazAccessibleObject;
|
|
begin
|
|
Result := nil;
|
|
if OwnerControl = nil then Exit;
|
|
Result := OwnerControl.GetSelectedChildAccessibleObject();
|
|
end;
|
|
|
|
function TLazAccessibleObject.GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject;
|
|
begin
|
|
Result := nil;
|
|
if OwnerControl = nil then Exit;
|
|
Result := OwnerControl.GetChildAccessibleObjectAtPos(APos);
|
|
end;
|
|
|
|
function TLazAccessibleObject.GetEnumerator: TLazAccessibleObjectEnumerator;
|
|
begin
|
|
Result:=TLazAccessibleObjectEnumerator.Create(FChildrenSortedForDataObject);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
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;
|
|
|
|
procedure RaiseLoop;
|
|
begin
|
|
raise ELayoutException.Create('TControl.AdjustSize loop detected '+DbgSName(Self)+' Bounds='+dbgs(BoundsRect));
|
|
end;
|
|
|
|
begin
|
|
{$IFDEF VerboseAdjustSize}
|
|
if (not (cfAutoSizeNeeded in FControlFlags))
|
|
and (Parent=nil)
|
|
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 begin
|
|
if cfKillAdjustSize in FControlFlags then
|
|
RaiseLoop;
|
|
if not AutoSizeDelayed then
|
|
DoAllAutoSize;
|
|
end;
|
|
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;
|
|
|
|
procedure TControl.EndDrag(Drop: Boolean);
|
|
begin
|
|
if Dragging then
|
|
DragManager.DragStop(Drop);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl.BeginAutoDrag
|
|
------------------------------------------------------------------------------}
|
|
procedure TControl.BeginAutoDrag;
|
|
begin
|
|
{$IFDEF VerboseDrag}
|
|
debugln(['TControl.BeginAutoDrag ',DbgSName(Self)]);
|
|
{$ENDIF}
|
|
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
|
|
MoveRectToFit(ARect, NewDockSite.GetLogicalClientRect);
|
|
// consider Align to increase chance the width/height is kept
|
|
case Align of
|
|
alLeft: Types.OffsetRect(ARect,-ARect.Left,0);
|
|
alTop: Types.OffsetRect(ARect,0,-ARect.Top);
|
|
alRight: Types.OffsetRect(ARect,NewDockSite.ClientWidth-ARect.Right,0);
|
|
alBottom: Types.OffsetRect(ARect,0,NewDockSite.ClientHeight-ARect.Bottom);
|
|
end;
|
|
end;
|
|
//DebugLn('TControl.DoDock AFTER Adjusting ',DbgSName(Self),' ',dbgs(ARect),' Align=',DbgS(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
|
|
Result:=alNone;
|
|
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;
|
|
FDesktopFont := 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
|
|
//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, OldTop, OldWidth, OldHeight: Integer;
|
|
|
|
function PosSizeChanged: boolean;
|
|
begin
|
|
SizeChanged:= (FWidth <> OldWidth) or (FHeight <> OldHeight);
|
|
PosChanged:= (FLeft <> OldLeft) or (FTop <> OldTop);
|
|
Result:= SizeChanged or PosChanged;
|
|
end;
|
|
|
|
procedure DebugInvalidPos(N: integer);
|
|
begin
|
|
if (FLeft < Low(Smallint)) or (FLeft > High(Smallint))
|
|
or (FTop < Low(Smallint)) or (FTop > High(Smallint)) then
|
|
DebugLn(['TControl.ChangeBounds test(',N,')',DbgSName(Self),
|
|
' Old=',OldLeft,',',OldTop,',',OldWidth,',',OldHeight,
|
|
' New=',ALeft,',',ATop,',',AWidth,',',AHeight,
|
|
' Real=',FLeft,',',FTop,',',FWidth,',',FHeight]);
|
|
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 Assigned(Parent) and not KeepBase then
|
|
Parent.UpdateAlignIndex(Self);
|
|
|
|
// constraint the size
|
|
DoConstrainedResize(ALeft, ATop, AWidth, AHeight);
|
|
|
|
// check if something would change
|
|
SizeChanged := (FWidth <> AWidth) or (FHeight <> AHeight);
|
|
PosChanged := (FLeft <> ALeft) or (FTop <> ATop);
|
|
if not (SizeChanged or PosChanged) then Exit;
|
|
|
|
// check for loop.
|
|
if (not KeepBase) and (cfKillChangeBounds in GetTopParent.FControlFlags) then
|
|
raise ELayoutException.CreateFmt('TControl.ChangeBounds loop detected %s '+
|
|
'Left=%d,Top=%d,Width=%d,Height=%d NewLeft=%d,NewTop=%d,NewWidth=%d,NewHeight=%d',
|
|
[DbgSName(Self), Left,Top,Width,Height, aLeft,aTop,aWidth,aHeight]);
|
|
OldLeft := FLeft;
|
|
OldTop := FTop;
|
|
OldWidth := FWidth;
|
|
OldHeight := FHeight;
|
|
|
|
//DebugLn('TControl.ChangeBounds A ',DbgSName(Self),' Old=',dbgs(BoundsRect),' New=',dbgs(Bounds(ALeft,ATop,AWidth,AHeight)));
|
|
if not ((csLoading in ComponentState) or (Self is TWinControl)) then
|
|
InvalidateControl(IsControlVisible, False, true);
|
|
//DebugLn('TControl.ChangeBounds B ',Name,':',ClassName);
|
|
DoSetBounds(ALeft, ATop, AWidth, AHeight);
|
|
DebugInvalidPos(1);
|
|
|
|
// change base bounds
|
|
// (base bounds are the base for the automatic resizing)
|
|
if not KeepBase then
|
|
UpdateAnchorRules;
|
|
DebugInvalidPos(2);
|
|
|
|
// lock size messages
|
|
inc(FSizeLock);
|
|
try
|
|
// notify before autosizing
|
|
BoundsChanged;
|
|
if not PosSizeChanged then exit;
|
|
if (Parent<>nil) or SizeChanged then
|
|
AdjustSize;
|
|
finally
|
|
dec(FSizeLock);
|
|
end;
|
|
if not PosSizeChanged then exit;
|
|
DebugInvalidPos(3);
|
|
|
|
// 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;
|
|
DebugInvalidPos(4);
|
|
// notify user about resize
|
|
if (not (csLoading in ComponentState)) then
|
|
begin
|
|
Resize;
|
|
DebugInvalidPos(5);
|
|
CheckOnChangeBounds;
|
|
DebugInvalidPos(6);
|
|
// for delphi compatibility send size/move messages
|
|
if PosSizeChanged then
|
|
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;
|
|
|
|
procedure TControl.ScaleConstraints(Multiplier, Divider: Integer);
|
|
begin
|
|
with Constraints do
|
|
begin
|
|
if MinWidth > 0 then
|
|
MinWidth := MulDiv(MinWidth, Multiplier, Divider);
|
|
if MaxWidth > 0 then
|
|
MaxWidth := MulDiv(MaxWidth, Multiplier, Divider);
|
|
if MinHeight > 0 then
|
|
MinHeight := MulDiv(MinHeight, Multiplier, Divider);
|
|
if MaxHeight > 0 then
|
|
MaxHeight := MulDiv(MaxHeight, Multiplier, Divider);
|
|
end;
|
|
end;
|
|
|
|
function TControl.ScaleDesignToForm(const ASize: Integer): Integer;
|
|
var
|
|
ParentForm: TCustomDesignControl;
|
|
begin
|
|
ParentForm := NeedParentDesignControl(Self);
|
|
Result := MulDiv(ASize, ParentForm.PixelsPerInch, ParentForm.DesignTimePPI);
|
|
end;
|
|
|
|
function TControl.Scale96ToForm(const ASize: Integer): Integer;
|
|
var
|
|
ParentForm: TCustomDesignControl;
|
|
begin
|
|
ParentForm := NeedParentDesignControl(Self);
|
|
Result := MulDiv(ASize, ParentForm.PixelsPerInch, 96);
|
|
end;
|
|
|
|
function TControl.Scale96ToScreen(const ASize: Integer): Integer;
|
|
begin
|
|
Result := MulDiv(ASize, Screen.PixelsPerInch, 96);
|
|
end;
|
|
|
|
function TControl.ScaleFormTo96(const ASize: Integer): Integer;
|
|
var
|
|
ParentForm: TCustomDesignControl;
|
|
begin
|
|
ParentForm := NeedParentDesignControl(Self);
|
|
Result := MulDiv(ASize, 96, ParentForm.PixelsPerInch);
|
|
end;
|
|
|
|
function TControl.ScaleFormToDesign(const ASize: Integer): Integer;
|
|
var
|
|
ParentForm: TCustomDesignControl;
|
|
begin
|
|
ParentForm := NeedParentDesignControl(Self);
|
|
Result := MulDiv(ASize, ParentForm.DesignTimePPI, ParentForm.PixelsPerInch);
|
|
end;
|
|
|
|
function TControl.ScaleScreenTo96(const ASize: Integer): Integer;
|
|
begin
|
|
Result := MulDiv(ASize, 96, Screen.PixelsPerInch);
|
|
end;
|
|
|
|
function TControl.Scale96ToFont(const ASize: Integer): Integer;
|
|
begin
|
|
Result := MulDiv(ASize, Font.PixelsPerInch, 96);
|
|
end;
|
|
|
|
function TControl.ScaleFontTo96(const ASize: Integer): Integer;
|
|
begin
|
|
Result := MulDiv(ASize, 96, Font.PixelsPerInch);
|
|
end;
|
|
|
|
function TControl.ScaleScreenToFont(const ASize: Integer): Integer;
|
|
begin
|
|
Result := MulDiv(ASize, Font.PixelsPerInch, Screen.PixelsPerInch);
|
|
end;
|
|
|
|
function TControl.ScaleFontToScreen(const ASize: Integer): Integer;
|
|
begin
|
|
Result := MulDiv(ASize, Screen.PixelsPerInch, Font.PixelsPerInch);
|
|
end;
|
|
|
|
procedure TControl.ScaleFontsPPI(const AToPPI: Integer;
|
|
const AProportion: Double);
|
|
begin
|
|
// Problem: all fonts have to be scaled.
|
|
// Override this function - list all custom fonts in the overriden procedure
|
|
|
|
DoScaleFontPPI(Font, AToPPI, AProportion);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl.ChangeScale
|
|
|
|
Scale contorl by factor Multiplier/Divider
|
|
------------------------------------------------------------------------------}
|
|
procedure TControl.ChangeScale(Multiplier, Divider: Integer);
|
|
var
|
|
R: TRect;
|
|
begin
|
|
if Multiplier <> Divider then
|
|
begin
|
|
ScaleConstraints(Multiplier, Divider);
|
|
if not ParentFont then
|
|
Font.Height := MulDiv(GetFontData(Font.Reference.Handle).Height, Multiplier, Divider);
|
|
R := BaseBounds;
|
|
if (Self is TCustomForm) and (GetParentForm(Self, True) = Self) then
|
|
begin
|
|
//Dont change Left,Top if this is the topmost form
|
|
R.Right := R.Left + MulDiv(R.Right-R.Left, Multiplier, Divider);
|
|
R.Bottom := R.Top + MulDiv(R.Bottom-R.Top, Multiplier, Divider);
|
|
end
|
|
else
|
|
begin
|
|
R.Left := MulDiv(R.Left, Multiplier, Divider);
|
|
R.Top := MulDiv(R.Top, Multiplier, Divider);
|
|
R.Right := MulDiv(R.Right, Multiplier, Divider);
|
|
R.Bottom := MulDiv(R.Bottom, Multiplier, Divider);
|
|
end;
|
|
BoundsRect := R;
|
|
end;
|
|
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{$IFDEF DebugDisableAutoSizing}('TControl.CreateFloatingDockSite'){$ENDIF};
|
|
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));
|
|
{$IFDEF DebugDisableAutoSizing}
|
|
debugln('TControl.CreateFloatingDockSite A ',DbgSName(Self),' ',DbgSName(Result),' ',dbgs(Result.BoundsRect));
|
|
{$ENDIF}
|
|
Result.EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.CreateFloatingDockSite'){$ENDIF};
|
|
end;
|
|
end;
|
|
|
|
procedure TControl.ExecuteDefaultAction;
|
|
begin
|
|
end;
|
|
|
|
procedure TControl.FixDesignFontsPPI(const ADesignTimePPI: Integer);
|
|
begin
|
|
// Problem: Font.PixelsPerInch isn't saved in the LFM, therefore the
|
|
// design-time font PPI is different from the one that is loaded on target
|
|
// machine, which results in different font scaling.
|
|
// DoFixDesignFont restores the corrent design-time font PPI so that it can
|
|
// be used for LCL HighDPI scaling.
|
|
// Override this function - list all custom fonts in the overriden procedure
|
|
// To-Do: maybe save Font.PixelsPerInch in the LFM and remove this?
|
|
|
|
DoFixDesignFontPPI(Font, ADesignTimePPI);
|
|
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 is FloatingDockSiteClass)
|
|
and (HostDockSite.DockClientCount<=1);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TControl.GetFloatingDockSiteClass: TWinControlClass;
|
|
------------------------------------------------------------------------------}
|
|
function TControl.GetFloatingDockSiteClass: TWinControlClass;
|
|
begin
|
|
Result := FFloatingDockSiteClass;
|
|
end;
|
|
|
|
procedure TControl.BeforeDragStart;
|
|
begin
|
|
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.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;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TControl.IsEnabled
|
|
Params: none
|
|
Returns: Boolean
|
|
|
|
Returns True only if both TControl and it's parent hierarchy are enabled.
|
|
Used internally by TGraphicControls for painting and various states during
|
|
runtime.
|
|
------------------------------------------------------------------------------}
|
|
function TControl.IsEnabled: Boolean;
|
|
var
|
|
TheControl: TControl;
|
|
begin
|
|
TheControl := Self;
|
|
repeat
|
|
Result := TheControl.Enabled;
|
|
TheControl := TheControl.Parent;
|
|
until (TheControl = nil) or (not Result);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TControl.IsParentColor
|
|
Params: none
|
|
Returns: Boolean
|
|
|
|
Used at places where we need to check ParentColor property from TControl.
|
|
Property is protected, so this function avoids hacking to get
|
|
protected property value.
|
|
------------------------------------------------------------------------------}
|
|
function TControl.IsParentColor: Boolean;
|
|
begin
|
|
Result := FParentColor;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TControl.IsParentFont
|
|
Params: none
|
|
Returns: Boolean
|
|
|
|
Used at places where we need to check ParentFont property from TControl.
|
|
Property is protected, so this function avoids hacking to get
|
|
protected property value.
|
|
------------------------------------------------------------------------------}
|
|
function TControl.IsParentFont: Boolean;
|
|
begin
|
|
Result := FParentFont;
|
|
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
|
|
if FMouseInClient then
|
|
Exit;
|
|
|
|
FMouseInClient := True;
|
|
|
|
// broadcast to parents first
|
|
if Assigned(Parent) then
|
|
Parent.Perform(CM_MOUSEENTER, 0, LParam(Self));
|
|
|
|
// if it is not a child message then perform an event
|
|
if (Message.LParam = 0) then
|
|
MouseEnter;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl.CMMouseLeave
|
|
------------------------------------------------------------------------------}
|
|
procedure TControl.CMMouseLeave(var Message: TLMessage);
|
|
begin
|
|
if not FMouseInClient then
|
|
Exit;
|
|
|
|
FMouseInClient := False;
|
|
|
|
// broadcast to parents first
|
|
if Assigned(Parent) then
|
|
Parent.Perform(CM_MOUSELEAVE, 0, LParam(Self));
|
|
|
|
// if it is not a child message then perform an event
|
|
if (Message.LParam = 0) then
|
|
MouseLeave;
|
|
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.CMCursorChanged(var Message: TLMessage);
|
|
begin
|
|
if not (csDesigning in ComponentState) then
|
|
SetTempCursor(Cursor);
|
|
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
|
|
if Assigned(FParent) then
|
|
begin
|
|
Font.BeginUpdate;
|
|
try
|
|
Font.PixelsPerInch := FParent.Font.PixelsPerInch; // PixelsPerInch isn't assigned
|
|
Font := FParent.Font;
|
|
finally
|
|
Font.EndUpdate;
|
|
end;
|
|
end;
|
|
FParentFont := True;
|
|
end;
|
|
//call here for compatibility with older LCL code
|
|
ParentFontChanged;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl.CMParentShowHintChanged
|
|
|
|
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.GetParentBackground: Boolean;
|
|
begin
|
|
Result := csParentBackground in ControlStyle;
|
|
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 SameRect(@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(TheMessage: TLMessage);
|
|
var
|
|
MouseMessage: TLMMouse absolute TheMessage;
|
|
P: TPoint;
|
|
NewMouseControl: TControl;
|
|
begin
|
|
if Assigned(Application) then
|
|
begin
|
|
NewMouseControl := GetCaptureControl;
|
|
if NewMouseControl = nil then
|
|
begin
|
|
P := GetMousePosFromMessage(MouseMessage.Pos);
|
|
p := ClientToScreen(P);
|
|
NewMouseControl := Application.GetControlAtPos(P);
|
|
end;
|
|
Application.DoBeforeMouseMessage(NewMouseControl);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TControl.ColorIsStored: boolean;
|
|
------------------------------------------------------------------------------}
|
|
function TControl.ColorIsStored: Boolean;
|
|
begin
|
|
Result := not ParentColor;
|
|
end;
|
|
|
|
function TControl.GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor;
|
|
const
|
|
DefColors: array[TDefaultColorType] of TColor = (
|
|
{ dctBrush } clWindow,
|
|
{ dctFont } clWindowText
|
|
);
|
|
begin
|
|
Result := TWSControlClass(WidgetSetClass).GetDefaultColor(Self, DefaultColorType);
|
|
if (Self.Color = clDefault) and ParentColor and Assigned(Parent) then
|
|
Result := Parent.GetDefaultColor(DefaultColorType) // recursion
|
|
else
|
|
if Result = clDefault then Result := DefColors[DefaultColorType]; // backstop
|
|
end;
|
|
|
|
function TControl.GetColorResolvingParent: TColor;
|
|
begin
|
|
if Color = clDefault then
|
|
Result := GetDefaultColor(dctBrush) // GetDefaultColor resolves the parent
|
|
else
|
|
Result := Color;
|
|
end;
|
|
|
|
function TControl.GetRGBColorResolvingParent: TColor;
|
|
begin
|
|
Result := ColorToRGB(GetColorResolvingParent());
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl.DoConstrainedResize
|
|
------------------------------------------------------------------------------}
|
|
procedure TControl.DoConstrainedResize(var NewLeft, NewTop, NewWidth, NewHeight: Integer);
|
|
var
|
|
MinWidth, MinHeight, MaxWidth, MaxHeight : TConstraintSize;
|
|
begin
|
|
if NewWidth<0 then NewWidth:=0;
|
|
if NewHeight<0 then NewHeight:=0;
|
|
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 Parent <> nil then Parent.InvalidatePreferredSize;
|
|
AdjustSize;
|
|
end;
|
|
|
|
function TControl.IsBorderSpacingInnerBorderStored: Boolean;
|
|
begin
|
|
Result:=BorderSpacing.InnerBorder<>0;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl IsCaptionStored
|
|
------------------------------------------------------------------------------}
|
|
function TControl.IsCaptionStored: Boolean;
|
|
begin
|
|
Result := (ActionLink = nil) or not ActionLink.IsCaptionLinked;
|
|
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.DoFixDesignFontPPI
|
|
------------------------------------------------------------------------------}
|
|
procedure TControl.DoFixDesignFontPPI(const AFont: TFont;
|
|
const ADesignTimePPI: Integer);
|
|
var
|
|
H: Integer;
|
|
OldParentFont: Boolean;
|
|
begin
|
|
if AFont.PixelsPerInch <> ADesignTimePPI then
|
|
begin
|
|
OldParentFont := ParentFont;
|
|
try
|
|
H := AFont.Height;
|
|
AFont.BeginUpdate;
|
|
try
|
|
AFont.Height := MulDiv(H, AFont.PixelsPerInch, ADesignTimePPI);
|
|
AFont.PixelsPerInch := ADesignTimePPI;
|
|
finally
|
|
AFont.EndUpdate;
|
|
end;
|
|
finally
|
|
FParentFont := OldParentFont; // change ParentFont without triggering CM_PARENTFONTCHANGED
|
|
end;
|
|
end;
|
|
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;
|
|
begin
|
|
if Parent = nil then
|
|
raise EInvalidOperation.CreateFmt(sParentRequired, [Name]);
|
|
Result := Parent.ClientOrigin;
|
|
Inc(Result.X, FLeft);
|
|
Inc(Result.Y, FTop);
|
|
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.ClientToScreen(const ARect: TRect): TRect;
|
|
var
|
|
P : TPoint;
|
|
begin
|
|
P := ClientToScreen(Point(0, 0));
|
|
Result := ARect;
|
|
Result.Offset(P);
|
|
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;
|
|
|
|
function TControl.ClientToParent(const Point: TPoint; AParent: TWinControl): TPoint;
|
|
begin
|
|
if not Assigned(AParent) then
|
|
AParent := Parent;
|
|
if not AParent.IsParentOf(Self) then
|
|
raise EInvalidOperation.CreateFmt(rsControlIsNotAParent, [AParent.Name, Name]);
|
|
Result := AParent.ScreenToClient(ClientToScreen(Point));
|
|
end;
|
|
|
|
function TControl.ParentToClient(const Point: TPoint; AParent: TWinControl): TPoint;
|
|
begin
|
|
if not Assigned(AParent) then
|
|
AParent := Parent;
|
|
if not AParent.IsParentOf(Self) then
|
|
raise EInvalidOperation.CreateFmt(rsControlIsNotAParent, [AParent.Name, Name]);
|
|
Result := ScreenToClient(AParent.ClientToScreen(Point));
|
|
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 := Assigned(FOnDragOver);
|
|
if Accept then
|
|
FOnDragOver(Self,Source,X,Y,State,Accept);
|
|
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;
|
|
|
|
procedure TControl.SetAccessibleName(AValue: TCaption);
|
|
begin
|
|
FAccessibleObject.AccessibleName := AValue;
|
|
end;
|
|
|
|
procedure TControl.SetAccessibleDescription(AValue: TCaption);
|
|
begin
|
|
FAccessibleObject.AccessibleDescription := AValue;
|
|
end;
|
|
|
|
procedure TControl.SetAccessibleValue(AValue: TCaption);
|
|
begin
|
|
FAccessibleObject.AccessibleValue := AValue;
|
|
end;
|
|
|
|
procedure TControl.SetAccessibleRole(AValue: TLazAccessibilityRole);
|
|
begin
|
|
FAccessibleObject.AccessibleRole := AValue;
|
|
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;
|
|
ParentColor := False;
|
|
ParentBackground := False;
|
|
Perform(CM_COLORCHANGED, 0, 0);
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl CanAutoSize
|
|
------------------------------------------------------------------------------}
|
|
function TControl.CanAutoSize(var NewWidth, NewHeight : Integer): Boolean;
|
|
begin
|
|
Result := True;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl Dragging
|
|
------------------------------------------------------------------------------}
|
|
function TControl.Dragging: Boolean;
|
|
begin
|
|
Result := DragManager.Dragging(Self);
|
|
end;
|
|
|
|
// accessibility
|
|
function TControl.GetAccessibleObject: TLazAccessibleObject;
|
|
begin
|
|
Result := FAccessibleObject;
|
|
end;
|
|
|
|
function TControl.CreateAccessibleObject: TLazAccessibleObject;
|
|
begin
|
|
Result := TLazAccessibleObject.Create(Self);
|
|
end;
|
|
|
|
function TControl.GetSelectedChildAccessibleObject: TLazAccessibleObject;
|
|
begin
|
|
Result := nil;
|
|
end;
|
|
|
|
function TControl.GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject;
|
|
begin
|
|
Result := nil;
|
|
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 := (Parent<>nil) and Parent.HandleAllocated and (GetCaptureControl = Self);
|
|
end;
|
|
|
|
function TControl.GetMousePosFromMessage(const MessageMousePos: TSmallPoint
|
|
): TPoint;
|
|
begin
|
|
if (Width>32767) or (Height>32767) then
|
|
begin
|
|
GetCursorPos(Result);
|
|
Result := ScreenToClient(Result);
|
|
end else
|
|
Result := SmallPointToPoint(MessageMousePos);
|
|
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;
|
|
|
|
procedure TControl.DoScaleFontPPI(const AFont: TFont; const AToPPI: Integer;
|
|
const AProportion: Double);
|
|
begin
|
|
// If AFont.PixelsPerInch is different from "Screen.PixelsPerInch" (=GetDeviceCaps(DC, LOGPIXELSX))
|
|
// then the font doesn't scale -> we have to assign a nonzero height value.
|
|
if (AFont.Height=0) and not (csDesigning in ComponentState) then
|
|
AFont.Height := MulDiv(GetFontData(AFont.Reference.Handle).Height, AFont.PixelsPerInch, Screen.PixelsPerInch);
|
|
if AToPPI>0 then
|
|
AFont.PixelsPerInch := AToPPI
|
|
else
|
|
AFont.PixelsPerInch := Round(AFont.PixelsPerInch*AProportion);
|
|
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
|
|
DoCallNotifyHandler(chtOnVisibleChanged);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TControl.EnabledChanging;
|
|
------------------------------------------------------------------------------}
|
|
procedure TControl.EnabledChanging;
|
|
begin
|
|
DoCallNotifyHandler(chtOnEnabledChanging);
|
|
end;
|
|
|
|
procedure TControl.EnabledChanged;
|
|
begin
|
|
DoCallNotifyHandler(chtOnEnabledChanged);
|
|
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,not AsFirst);
|
|
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.DoCallKeyEventHandler(HandlerType: TControlHandlerType;
|
|
var Key: Word; Shift: TShiftState);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := FControlHandlers[HandlerType].Count;
|
|
while FControlHandlers[HandlerType].NextDownIndex(i) do
|
|
TKeyEvent(FControlHandlers[HandlerType][i])(Self, Key, Shift);
|
|
end;
|
|
|
|
procedure TControl.DoCallMouseWheelEventHandler(HandlerType: TControlHandlerType;
|
|
Shift: TShiftState; WheelDelta: Integer;
|
|
MousePos: TPoint; var Handled: Boolean);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := FControlHandlers[HandlerType].Count;
|
|
//debugln('TControl.DoCallMouseWheelEventHandler A: Handled = ',DbgS(Handled),', Count = ',DbgS(i));
|
|
while (not Handled) and FControlHandlers[HandlerType].NextDownIndex(i) do
|
|
begin
|
|
TMouseWheelEvent(FControlHandlers[HandlerType][i])(Self, Shift, WheelDelta, MousePos, Handled);
|
|
//debugln('TControl.DoCallMouseWheelEventHandler B: i = ',Dbgs(i),', Handled = ',DbgS(Handled));
|
|
end;
|
|
//debugln('TControl.DoCallMouseWheelEventHandler End: Handled = ',DbgS(Handled));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TControl.DoContextPopup(const MousePos: TPoint;
|
|
var Handled: Boolean);
|
|
------------------------------------------------------------------------------}
|
|
procedure TControl.DoContextPopup(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 (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.GetAccessibleName: TCaption;
|
|
begin
|
|
Result := FAccessibleObject.AccessibleName;
|
|
end;
|
|
|
|
function TControl.GetAccessibleDescription: TCaption;
|
|
begin
|
|
Result := FAccessibleObject.AccessibleDescription;
|
|
end;
|
|
|
|
function TControl.GetAccessibleValue: TCaption;
|
|
begin
|
|
Result := FAccessibleObject.AccessibleValue;
|
|
end;
|
|
|
|
function TControl.GetAccessibleRole: TLazAccessibilityRole;
|
|
begin
|
|
Result := FAccessibleObject.AccessibleRole;
|
|
end;
|
|
|
|
function TControl.CaptureMouseButtonsIsStored: Boolean;
|
|
begin
|
|
Result := FCaptureMouseButtons <> [mbLeft];
|
|
end;
|
|
|
|
function TControl.GetAnchorSide(Kind: TAnchorKind): TAnchorSide;
|
|
begin
|
|
Result:=FAnchorSides[Kind];
|
|
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.GetChildrenRect(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.GetChildrenRect(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 := GetDesignerForm(Self);
|
|
//debugln(['TControl.WndProc ',dbgsname(Self)]);
|
|
if Assigned(Form) and Assigned(Form.Designer) and Form.Designer.IsDesignMsg(Self, TheMessage) then
|
|
Exit;
|
|
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
|
|
case TheMessage.Msg of
|
|
|
|
LM_MOUSEMOVE:
|
|
begin
|
|
Application.HintMouseMessage(Self, TheMessage);
|
|
end;
|
|
|
|
LM_LBUTTONDOWN,
|
|
LM_LBUTTONDBLCLK:
|
|
begin
|
|
Include(FControlState, csLButtonDown);
|
|
{ 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.
|
|
}
|
|
if FDragMode = dmAutomatic then
|
|
BeginAutoDrag;
|
|
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);
|
|
var
|
|
MP: TPoint;
|
|
begin
|
|
//DebugLn('TControl.DoMouseDown ',DbgSName(Self),' ');
|
|
if not (csNoStdEvents in ControlStyle) then
|
|
begin
|
|
MP := GetMousePosFromMessage(Message.Pos);
|
|
MouseDown(Button, KeysToShiftState(Message.Keys) + Shift, MP.X, MP.Y);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl DoMouseUp "Event Handler"
|
|
------------------------------------------------------------------------------}
|
|
procedure TControl.DoMouseUp(var Message: TLMMouse; Button: TMouseButton);
|
|
var
|
|
P, MP: TPoint;
|
|
begin
|
|
if not (csNoStdEvents in ControlStyle) then
|
|
begin
|
|
MP := GetMousePosFromMessage(Message.Pos);
|
|
if (Button in [mbLeft, mbRight]) and DragManager.IsDragging then
|
|
begin
|
|
P := ClientToScreen(MP);
|
|
DragManager.MouseUp(Button, KeysToShiftState(Message.Keys), P.X, P.Y);
|
|
Message.Result := 1;
|
|
end;
|
|
MouseUp(Button, KeysToShiftState(Message.Keys), MP.X, MP.Y);
|
|
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
|
|
//debugln('TControl.DoMouseWheel calling DoCallMouseWheelEventHandler');
|
|
DoCallMouseWheelEventHandler(chtOnMouseWheel, Shift, WheelDelta, MousePos, Result);
|
|
end;
|
|
|
|
if not Result
|
|
then begin
|
|
if WheelDelta < 0
|
|
then Result := DoMouseWheelDown(Shift, MousePos)
|
|
else Result := DoMouseWheelUp(Shift, MousePos);
|
|
end;
|
|
end;
|
|
|
|
function TControl.DoMouseWheelHorz(Shift: TShiftState; WheelDelta: Integer;
|
|
MousePos: TPoint): Boolean;
|
|
begin
|
|
Result := False;
|
|
|
|
if Assigned(FOnMouseWheelHorz)
|
|
then FOnMouseWheelHorz(Self, Shift, WheelDelta, MousePos, Result);
|
|
if not Result then
|
|
begin
|
|
//debugln('TControl.DoMouseWheelHorz calling DoCallMouseWheelEventHandler');
|
|
DoCallMouseWheelEventHandler(chtOnMouseWheelHorz, Shift, WheelDelta, MousePos, Result);
|
|
end;
|
|
|
|
if not Result
|
|
then begin
|
|
if WheelDelta < 0
|
|
then Result := DoMouseWheelLeft(Shift, MousePos)
|
|
else Result := DoMouseWheelRight(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;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl DoMouseWheelLeft "Event Handler"
|
|
------------------------------------------------------------------------------}
|
|
function TControl.DoMouseWheelLeft(Shift: TShiftState; MousePos: TPoint): Boolean;
|
|
begin
|
|
Result := False;
|
|
if Assigned(FOnMouseWheelLeft) then
|
|
FOnMouseWheelLeft(Self, Shift, MousePos, Result);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl DoMouseWheelRight "Event Handler"
|
|
------------------------------------------------------------------------------}
|
|
function TControl.DoMouseWheelRight(Shift: TShiftState; MousePos: TPoint): Boolean;
|
|
begin
|
|
Result := False;
|
|
if Assigned(FOnMouseWheelRight) then
|
|
FOnMouseWheelRight(Self, Shift, MousePos, Result);
|
|
end;
|
|
|
|
procedure TControl.SetAnchorSide(Kind: TAnchorKind; AValue: TAnchorSide);
|
|
begin
|
|
GetAnchorSide(Kind).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 := GetMousePosFromMessage(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
|
|
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
|
|
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
|
|
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;
|
|
|
|
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
|
|
//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
|
|
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
|
|
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;
|
|
|
|
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
|
|
//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
|
|
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
|
|
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;
|
|
|
|
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
|
|
//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
|
|
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
|
|
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;
|
|
|
|
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
|
|
//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, GetMousePosFromMessage(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
|
|
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
|
|
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;
|
|
|
|
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;
|
|
lState: TShiftState;
|
|
SP: TSmallPoint;
|
|
begin
|
|
SP.X := Message.X; // cannot use SmallPoint() here due to FPC inconsistency in Classes.TSmallPoint<>Types.TSmallPoint on Linux
|
|
SP.Y := Message.Y;
|
|
MousePos := GetMousePosFromMessage(SP);
|
|
|
|
lState := Message.State - [ssCaps, ssNum, ssScroll]; // Remove unreliable states, see http://bugs.freepascal.org/view.php?id=20065
|
|
if DoMouseWheel(lState, Message.WheelDelta, MousePos) then
|
|
Message.Result := 1 // handled, skip further handling by interface
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TControl.WMMouseHWheel(var Message: TLMMouseEvent);
|
|
var
|
|
MousePos: TPoint;
|
|
lState: TShiftState;
|
|
SP: TSmallPoint;
|
|
begin
|
|
SP.X := Message.X; // cannot use SmallPoint() here due to FPC inconsistency in Classes.TSmallPoint<>Types.TSmallPoint on Linux
|
|
SP.Y := Message.Y;
|
|
MousePos := GetMousePosFromMessage(SP);
|
|
|
|
lState := Message.State - [ssCaps, ssNum, ssScroll]; // Remove unreliable states, see http://bugs.freepascal.org/view.php?id=20065
|
|
if DoMouseWheelHorz(lState, Message.WheelDelta, MousePos) then
|
|
Message.Result := 1 // handled, skip further handling by interface
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl Click
|
|
------------------------------------------------------------------------------}
|
|
procedure TControl.Click;
|
|
|
|
function OnClickIsActionExecute: boolean;
|
|
begin
|
|
Result:=false;
|
|
if Action=nil then exit;
|
|
if not Assigned(Action.OnExecute) then exit;
|
|
if not Assigned(FOnClick) then exit;
|
|
Result:=SameMethod(TMethod(FOnClick),TMethod(Action.OnExecute));
|
|
end;
|
|
|
|
var
|
|
CallAction: Boolean;
|
|
begin
|
|
//DebugLn(['TControl.Click ',DbgSName(Self)]);
|
|
CallAction:=(not (csDesigning in ComponentState)) and (ActionLink <> nil);
|
|
|
|
// first call our own OnClick if it differs from Action.OnExecute
|
|
if Assigned(FOnClick)
|
|
and ((not CallAction) or (not OnClickIsActionExecute)) then
|
|
FOnClick(Self);
|
|
// then trigger the Action
|
|
if CallAction then
|
|
ActionLink.Execute(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.RealCursor <> 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;
|
|
begin
|
|
Result := ChildClassAllowed(ChildClass);
|
|
if (not Result) and ExceptionOnInvalid then
|
|
raise EInvalidOperation.CreateFmt(rsControlClassCantContainChildClass, [ClassName, ChildClass.ClassName]);
|
|
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
|
|
raise EInvalidOperation.Create(rsAControlCanNotHaveItselfAsParent);
|
|
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;
|
|
Needed: Boolean;
|
|
begin
|
|
if AControl.AutoSizeDelayed then exit;
|
|
Needed:=cfAutoSizeNeeded in AControl.FControlFlags;
|
|
|
|
//DebugLn(['TControl.DoAllAutoSize.AutoSizeControl ',DbgSName(AControl),' AutoSize=',AControl.AutoSize,' IsControlVisible=',AControl.IsControlVisible,' cfAutoSizeNeeded=',Needed]);
|
|
Exclude(AControl.FControlFlags, cfAutoSizeNeeded);
|
|
if not AControl.IsControlVisible then exit;
|
|
|
|
if Needed and AControl.AutoSize and
|
|
(not (csDesignInstance 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.
|
|
// Call all OnResize events so they will hopefully only invoke one more
|
|
// loop, instead of one per OnResize.
|
|
var
|
|
AWinControl: TWinControl;
|
|
i: Integer;
|
|
begin
|
|
if AControl = nil then Exit(True);
|
|
Result := False;
|
|
if AControl is TWinControl then
|
|
begin
|
|
AWinControl := TWinControl(AControl);
|
|
for i := 0 to AWinControl.ControlCount - 1 do
|
|
if AWinControl.Controls[i].IsControlVisible
|
|
and not CallAllOnResize(AWinControl.Controls[i]) then
|
|
exit;
|
|
end;
|
|
{$IFDEF VerboseOnResize}
|
|
debugln(['TControl.DoAllAutoSize ',DbgSName(AControl),' calling Resize ...']);
|
|
{$ENDIF}
|
|
AControl.Resize;
|
|
Result := True;
|
|
end;
|
|
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if Parent <> nil then
|
|
raise EInvalidOperation.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
|
|
i:=0;
|
|
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);
|
|
inc(i);
|
|
if i=1000 then
|
|
Include(FControlFlags,cfKillChangeBounds);
|
|
if i=2000 then
|
|
Include(FControlFlags,cfKillInvalidatePreferredSize);
|
|
if i=3000 then
|
|
Include(FControlFlags,cfKillAdjustSize);
|
|
end;
|
|
finally
|
|
FControlFlags:=FControlFlags-[cfKillChangeBounds,
|
|
cfKillInvalidatePreferredSize,cfKillAdjustSize];
|
|
FAutoSizingAll := False;
|
|
end;
|
|
{$IFDEF VerboseAllAutoSize}
|
|
DebugLn(['TControl.DoAllAutoSize END ',DbgSName(Self),' ',dbgs(BoundsRect)]);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TControl.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
|
|
const AXProportion, AYProportion: Double);
|
|
var
|
|
AAWidth, AAHeight: Boolean;
|
|
NewLeft, NewTop, NewWidth, NewHeight, NewRight, NewBottom, OldWidth, OldHeight,
|
|
NewBaseLeft, NewBaseTop, NewBaseWidth, NewBaseHeight: Integer;
|
|
begin
|
|
// Apply the changes
|
|
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
|
|
begin
|
|
// Dimensions
|
|
AAWidth := False;
|
|
AAHeight := False;
|
|
NewLeft := Left;
|
|
NewTop := Top;
|
|
NewWidth := Width;
|
|
NewHeight := Height;
|
|
OldWidth := Width;
|
|
OldHeight := Height;
|
|
|
|
ShouldAutoAdjust(AAWidth, AAHeight);
|
|
AAWidth := AAWidth and (Align in [alNone, alLeft, alRight])
|
|
and not((akLeft in Anchors) and (akRight in Anchors));
|
|
AAHeight := AAHeight and (Align in [alNone, alTop, alBottom])
|
|
and not((akTop in Anchors) and (akBottom in Anchors));
|
|
|
|
if (Align in [alNone, alRight]) and (akLeft in Anchors) then
|
|
NewLeft := Round(NewLeft * AXProportion);
|
|
if (Align=alNone) and (akRight in Anchors) and (Parent<>nil)
|
|
and (AnchorSideRight.Control=nil) then
|
|
begin
|
|
if not(akLeft in Anchors) then
|
|
begin
|
|
NewRight := Round((Parent.ClientWidth-NewLeft-OldWidth) * AXProportion);
|
|
NewLeft := Parent.ClientWidth-NewRight-OldWidth
|
|
end else
|
|
begin
|
|
NewRight := Round((Parent.ClientWidth-Left-OldWidth) * AXProportion);
|
|
NewWidth := Parent.ClientWidth-NewLeft-NewRight;
|
|
end;
|
|
end;
|
|
|
|
if (Align in [alNone, alBottom]) and (akTop in Anchors) then
|
|
NewTop := Round(NewTop * AYProportion);
|
|
if (Align=alNone) and (akBottom in Anchors) and (Parent<>nil)
|
|
and (AnchorSideBottom.Control=nil) then
|
|
begin
|
|
if not(akTop in Anchors) then
|
|
begin
|
|
NewBottom := Round((Parent.ClientHeight-NewTop-OldHeight) * AYProportion);
|
|
NewTop := Parent.ClientHeight-NewBottom-OldHeight
|
|
end else
|
|
begin
|
|
NewBottom := Round((Parent.ClientHeight-Top-OldHeight) * AYProportion);
|
|
NewHeight := Parent.ClientHeight-NewTop-NewBottom;
|
|
end;
|
|
end;
|
|
|
|
if AAWidth then
|
|
NewWidth := Round(Width * AXProportion);
|
|
if AAHeight then
|
|
NewHeight := Round(Height * AYProportion);
|
|
|
|
BorderSpacing.AutoAdjustLayout(AXProportion, AYProportion);
|
|
Constraints.AutoAdjustLayout(AXProportion, AYProportion);
|
|
|
|
NewBaseLeft := NewLeft;
|
|
NewBaseTop := NewTop;
|
|
NewBaseWidth := NewWidth;
|
|
NewBaseHeight := NewHeight;
|
|
NewWidth := Constraints.MinMaxWidth(NewWidth);
|
|
NewHeight := Constraints.MinMaxHeight(NewHeight);
|
|
|
|
if AAWidth or (NewBaseWidth<>NewWidth) then
|
|
begin
|
|
if akRight in Anchors then
|
|
NewLeft := NewLeft-NewWidth+OldWidth;
|
|
end;
|
|
if AAHeight or (NewBaseHeight<>NewHeight) then
|
|
begin
|
|
if akBottom in Anchors then
|
|
NewTop := NewTop-NewHeight+OldHeight;
|
|
end;
|
|
if AAWidth and (akRight in Anchors) then
|
|
NewBaseLeft := NewBaseLeft-NewBaseWidth+OldWidth;
|
|
if AAHeight and (akBottom in Anchors) then
|
|
NewBaseTop := NewBaseTop-NewBaseHeight+OldHeight;
|
|
|
|
FBaseBounds.Left:=NewBaseLeft;
|
|
FBaseBounds.Top:=NewBaseTop;
|
|
FBaseBounds.Right:=NewBaseLeft+NewBaseWidth;
|
|
FBaseBounds.Bottom:=NewBaseTop+NewBaseHeight;
|
|
if Parent<>nil then
|
|
begin
|
|
FBaseParentClientSize.cx:=Parent.ClientWidth;
|
|
FBaseParentClientSize.cy:=Parent.ClientHeight;
|
|
end;
|
|
|
|
SetBoundsKeepBase(NewLeft, NewTop, NewWidth, NewHeight);
|
|
end;
|
|
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
|
|
// (TWinControl and TCustomForm override this)
|
|
or AutoSizeDelayedHandle
|
|
// 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 AutoSizeDelayedHandle then debugln('AutoSizeDelayedHandle')
|
|
else if ((Parent<>nil) and Parent.AutoSizeDelayed) then debugln('Parent.AutoSizeDelayed')
|
|
else debugln('?');
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TControl.AutoSizeDelayedReport: string;
|
|
begin
|
|
if (FAutoSizingLockCount>0) then
|
|
Result:='FAutoSizingLockCount='+dbgs(FAutoSizingLockCount)
|
|
else if csLoading in ComponentState then
|
|
Result:='csLoading'
|
|
else if csDestroying in ComponentState then
|
|
Result:='csDestroying'
|
|
else if cfLoading in FControlFlags then
|
|
Result:='cfLoading'
|
|
else if IsControlVisible then
|
|
Result:='not IsControlVisible'
|
|
else if AutoSizeDelayedHandle then
|
|
Result:='AutoSizeDelayedHandle'
|
|
else if Parent<>nil then
|
|
Result:=Parent.AutoSizeDelayedReport
|
|
else
|
|
Result:='?';
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl AutoSizeDelayedHandle
|
|
|
|
Returns true if AutoSize should be skipped / delayed because of its handle.
|
|
A TControl does not have a handle, so it needs a parent.
|
|
------------------------------------------------------------------------------}
|
|
function TControl.AutoSizeDelayedHandle: 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}
|
|
SetBounds(ARect.Left, ARect.Top,
|
|
Max(ARect.Right - ARect.Left, 0), Max(ARect.Bottom - ARect.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;
|
|
Perform(CM_CURSORCHANGED, 0, 0);
|
|
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
|
|
EnabledChanging;
|
|
FEnabled := Value;
|
|
Perform(CM_ENABLEDCHANGED, 0, 0);
|
|
EnabledChanged;
|
|
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 exit;
|
|
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 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
|
|
else if AComponent = FHostDockSite then
|
|
FHostDockSite := 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;
|
|
R: TRect;
|
|
begin
|
|
//DebugLn(['TControl.DoFloatMsg ',DbgSName(Self),' Floating=',Floating]);
|
|
if Floating and (Parent <> nil) then
|
|
begin
|
|
P := Parent.ClientToScreen(Point(Left, Top));
|
|
R := ADockSource.DockRect;
|
|
Parent.BoundsRect := Bounds(R.Left + Parent.Left - P.X, R.Top + Parent.Top - P.Y,
|
|
R.Right - R.Left + Parent.Width - Width, R.Bottom - R.Top + Parent.Height - Height);
|
|
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;
|
|
GetTextMethod: TMethod;
|
|
begin
|
|
// Check if GetTextBuf is overridden, otherwise we can call RealGetText directly
|
|
Assert(Assigned(@Self.GetTextBuf), 'TControl.GetText: GetTextBuf Method is Nil');
|
|
GetTextMethod := TMethod(@Self.GetTextBuf);
|
|
if GetTextMethod.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;
|
|
|
|
function TControl.IsClientHeightStored: Boolean;
|
|
begin
|
|
Result:=false;
|
|
end;
|
|
|
|
function TControl.IsClientWidthStored: Boolean;
|
|
begin
|
|
Result:=false;
|
|
end;
|
|
|
|
function TControl.WidthIsAnchored: Boolean;
|
|
var
|
|
CurAnchors: TAnchors;
|
|
begin
|
|
if Align=alCustom then exit(true); // width depends on parent
|
|
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
|
|
if Align=alCustom then exit(true); // height depends on parent
|
|
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
|
|
SetCaptureControl(nil);
|
|
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 CompareText('SubPanel',Name)=0 then begin
|
|
DebugLn(['[TControl.Resize] ',Name,':',ClassName,
|
|
' Last=',FLastResizeWidth,',',FLastResizeHeight,
|
|
' LastClient=',FLastResizeClientWidth,',',FLastResizeClientHeight,
|
|
' New=',Width,',',Height,
|
|
' NewClient=',ClientWidth,',',ClientHeight]);
|
|
DumpStack;
|
|
end;}
|
|
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;
|
|
|
|
{$IFDEF VerboseOnResize}
|
|
debugln(['TControl.LoadedAll ',DbgSName(Self),' calling Resize ...']);
|
|
{$ENDIF}
|
|
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
|
|
Include(FControlState, csReadingState);
|
|
inherited ReadState(Reader);
|
|
finally
|
|
Exclude(FControlState, csReadingState);
|
|
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;
|
|
|
|
procedure TControl.SetDesktopFont(const AValue: Boolean);
|
|
begin
|
|
if FDesktopFont <> AValue then
|
|
begin
|
|
FDesktopFont := AValue;
|
|
Perform(CM_SYSFONTCHANGED, 0, 0);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl SetAlign
|
|
------------------------------------------------------------------------------}
|
|
procedure TControl.SetAlign(Value: TAlign);
|
|
var
|
|
OldAlign: TAlign;
|
|
a: TAnchorKind;
|
|
OldBaseBounds: TRect;
|
|
begin
|
|
if FAlign = Value then exit;
|
|
//DebugLn(['TControl.SetAlign ',DbgSName(Self),' Old=',DbgS(FAlign),' New=',DbgS(Value),' ',Anchors<>AnchorAlign[FAlign]]);
|
|
DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetAlign'){$ENDIF};
|
|
try
|
|
OldBaseBounds:=BaseBounds;
|
|
OldAlign := FAlign;
|
|
FAlign := Value;
|
|
if (not (csLoading in ComponentState))
|
|
and (Align in [alLeft,alTop,alRight,alBottom,alClient]) then begin
|
|
// Align for alLeft,alTop,alRight,alBottom,alClient takes precedence
|
|
// over AnchorSides => clean up
|
|
for a:=low(TAnchorKind) to High(TAnchorKind) do
|
|
begin
|
|
if not (a in AnchorAlign[FAlign]) then continue;
|
|
AnchorSide[a].Control:=nil;
|
|
AnchorSide[a].Side:=asrTop;
|
|
end;
|
|
end;
|
|
// Notes:
|
|
// - if anchors had default values then change them to new default values
|
|
// This is done for Delphi compatibility.
|
|
// - Anchors are not stored if they are AnchorAlign[Align]
|
|
if (Anchors = AnchorAlign[OldAlign]) and (Anchors <> AnchorAlign[FAlign]) then
|
|
Anchors := AnchorAlign[FAlign];
|
|
if not (csLoading in ComponentState) then
|
|
BoundsRect:=OldBaseBounds;
|
|
//DebugLn(['TControl.SetAlign ',DbgSName(Self),' Cur=',DbgS(FAlign),' New=',DbgS(Value),' ',Anchors<>AnchorAlign[FAlign],' Anchors=',dbgs(Anchors)]);
|
|
finally
|
|
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetAlign'){$ENDIF};
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TControl SetAnchors
|
|
------------------------------------------------------------------------------}
|
|
procedure TControl.SetAnchors(const AValue: TAnchors);
|
|
var
|
|
NewAnchors: TAnchors;
|
|
a: TAnchorKind;
|
|
begin
|
|
if Anchors = AValue then Exit;
|
|
NewAnchors:=AValue-FAnchors;
|
|
FAnchors := AValue;
|
|
for a:=Low(TAnchorKind) to high(TAnchorKind) do
|
|
if (a in NewAnchors) and (AnchorSide[a].Side=asrCenter) then
|
|
AnchorSide[a].FixCenterAnchoring;
|
|
|
|
// Delphi Anchors depend on the current bounds of Self and Parent.ClientRect
|
|
// => fetch current BaseBounds
|
|
// for example:
|
|
// during disabled autosizing: Width:=100; Anchors:=Anchors+[akRight];
|
|
UpdateAnchorRules;
|
|
|
|
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 (not SameRect(@NewBaseBounds,@FBaseBounds))
|
|
or (NewBaseParentClientSize.cx<>FBaseParentClientSize.cx)
|
|
or (NewBaseParentClientSize.cy<>FBaseParentClientSize.cy)
|
|
then begin
|
|
//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;
|
|
FBaseParentClientSize:=NewBaseParentClientSize;
|
|
end;
|
|
Include(FControlFlags,cfBaseBoundsValid);
|
|
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=',DbgS(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.AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy;
|
|
const AFromPPI, AToPPI, AOldFormWidth, ANewFormWidth: Integer);
|
|
var
|
|
lXProportion, lYProportion: Double;
|
|
lMode: TLayoutAdjustmentPolicy;
|
|
savedParentFont: Boolean;
|
|
begin
|
|
// First resolve ladDefault
|
|
lMode := AMode;
|
|
if lMode = lapDefault then lMode := Application.LayoutAdjustmentPolicy;
|
|
|
|
// X-axis adjustment proportion
|
|
lXProportion := 1.0;
|
|
if lMode = lapAutoAdjustWithoutHorizontalScrolling then
|
|
begin
|
|
if AOldFormWidth > 0 then lXProportion := ANewFormWidth / AOldFormWidth;
|
|
end
|
|
else if lMode = lapAutoAdjustForDPI then
|
|
begin
|
|
if AFromPPI > 0 then lXProportion := AToPPI / AFromPPI;
|
|
end;
|
|
|
|
// y-axis adjustment proportion
|
|
if AFromPPI > 0 then lYProportion := AToPPI / AFromPPI
|
|
else lYProportion := 1.0;
|
|
|
|
DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.AutoAdjustLayout'){$ENDIF};
|
|
savedParentFont := ParentFont;
|
|
try
|
|
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
|
|
ScaleFontsPPI(AToPPI, lYProportion);
|
|
|
|
DoAutoAdjustLayout(lMode, lXProportion, lYProportion);
|
|
finally
|
|
ParentFont := savedParentFont;
|
|
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.AutoAdjustLayout'){$ENDIF};
|
|
end;
|
|
end;
|
|
|
|
// Auto-adjust the layout of controls.
|
|
procedure TControl.ShouldAutoAdjust(var AWidth, AHeight: Boolean);
|
|
begin
|
|
AWidth := not AutoSize;
|
|
AHeight := not AutoSize;
|
|
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 ELayoutException.CreateFmt('TWinControl.SetBounds (%s): Negative width %d not allowed.',
|
|
[DbgSName(Self), Value]);
|
|
if Value>=10000 then
|
|
raise ELayoutException.CreateFmt('TWinControl.SetBounds (%s): Width %d not allowed.',
|
|
[DbgSName(Self), Value]);
|
|
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;
|
|
const
|
|
Registered : boolean = False;
|
|
begin
|
|
if Registered then
|
|
Exit;
|
|
inherited WSRegisterClass;
|
|
RegisterControl;
|
|
RegisterPropertyToSkip(TControl, 'AlignWithMargins', 'VCL compatibility property', '');
|
|
RegisterPropertyToSkip(TControl, 'Ctl3D', 'VCL compatibility property', '');
|
|
RegisterPropertyToSkip(TControl, 'ParentCtl3D', 'VCL compatibility property', '');
|
|
RegisterPropertyToSkip(TControl, 'IsControl', 'VCL compatibility property', '');
|
|
RegisterPropertyToSkip(TControl, 'DesignSize', 'VCL compatibility property', '');
|
|
RegisterPropertyToSkip(TControl, 'ExplicitLeft', 'VCL compatibility property', '');
|
|
RegisterPropertyToSkip(TControl, 'ExplicitHeight', 'VCL compatibility property', '');
|
|
RegisterPropertyToSkip(TControl, 'ExplicitTop', 'VCL compatibility property', '');
|
|
RegisterPropertyToSkip(TControl, 'ExplicitWidth', 'VCL compatibility property', '');
|
|
Registered := True;
|
|
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 ELayoutException.CreateFmt('TWinControl.SetHeight (%s): Negative height %d not allowed.',
|
|
[DbgSName(Self), Value]);
|
|
if Value>=10000 then
|
|
raise ELayoutException.CreateFmt('TWinControl.SetBounds (%s): Height %d not allowed.',
|
|
[DbgSName(Self), Value]);
|
|
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;
|
|
|
|
procedure TControl.SetParentBackground(const AParentBackground: Boolean);
|
|
begin
|
|
if ParentBackground = AParentBackground then
|
|
Exit;
|
|
|
|
if AParentBackground then
|
|
ControlStyle := ControlStyle + [csParentBackground]
|
|
else
|
|
ControlStyle := ControlStyle - [csParentBackground];
|
|
Invalidate;
|
|
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);
|
|
var
|
|
MP: TPoint;
|
|
begin
|
|
{$IFDEF VerboseMouseBugfix}
|
|
DebugLn(['[TControl.WMMouseMove] ',Name,':',ClassName,' ',Message.XPos,',',Message.YPos]);
|
|
{$ENDIF}
|
|
MP := GetMousePosFromMessage(Message.Pos);
|
|
UpdateMouseCursor(MP.X,MP.Y);
|
|
if not (csNoStdEvents in ControlStyle) then
|
|
MouseMove(KeystoShiftState(Word(Message.Keys)), MP.X, MP.Y);
|
|
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 Assigned(AsWincontrol) then
|
|
AsWincontrol.InvalidatePreferredChildSizes;
|
|
AdjustSize;
|
|
if (not Visible) and Assigned(Parent) then
|
|
begin
|
|
// control became invisible, so AdjustSize was not propagated to Parent
|
|
// => propagate now
|
|
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) or (csDestroyingHandle in FControlState)) 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
|
|
{$IFDEF VerboseLCLHelp}
|
|
debugln(['TControl.ShowHelp ',DbgSName(Self)]);
|
|
{$ENDIF}
|
|
if HelpType = htContext then
|
|
begin
|
|
if HelpContext <> 0 then
|
|
begin
|
|
Application.HelpContext(HelpContext);
|
|
Exit;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if HelpKeyword <> '' then
|
|
begin
|
|
Application.HelpKeyword(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{$IFDEF DebugDisableAutoSizing}('TControl.Dock'){$ENDIF};
|
|
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<>nil) and (NewDockSite.FDockClients<>nil) then
|
|
NewDockSite.FDockClients.Remove(Self);
|
|
Exclude(FControlState, csDocking);
|
|
end;
|
|
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.Dock'){$ENDIF};
|
|
|
|
//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{$IFDEF DebugDisableAutoSizing}('TControl.ManualDock DropControl'){$ENDIF};
|
|
if NewDockSite<>nil then
|
|
NewDockSite.DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ManualDock NewDockSite'){$ENDIF};
|
|
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{$IFDEF DebugDisableAutoSizing}('TControl.ManualDock NewDockSite'){$ENDIF};
|
|
if DropControl<>nil then
|
|
DropControl.EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ManualDock DropControl'){$ENDIF};
|
|
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{$IFDEF DebugDisableAutoSizing}('TControl.ManualFloat'){$ENDIF};
|
|
// 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{$IFDEF DebugDisableAutoSizing}('TControl.ManualFloat'){$ENDIF};
|
|
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{$IFDEF DebugDisableAutoSizing}('TControl.ReplaceDockedControl'){$ENDIF};
|
|
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{$IFDEF DebugDisableAutoSizing}('TControl.ReplaceDockedControl'){$ENDIF};
|
|
end;
|
|
|
|
function TControl.Docked: Boolean;
|
|
begin
|
|
Result := Assigned(Parent) and (Parent = HostDockSite) and (GetParentForm(Parent) <> Parent);
|
|
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.AddHandlerOnEnabledChanging(
|
|
const OnEnabledChangingEvent: TNotifyEvent; AsFirst: Boolean);
|
|
begin
|
|
AddHandler(chtOnEnabledChanging,TMethod(OnEnabledChangingEvent),AsFirst);
|
|
end;
|
|
|
|
procedure TControl.RemoveHandlerOnEnabledChanging(
|
|
const OnEnabledChangingEvent: TNotifyEvent);
|
|
begin
|
|
RemoveHandler(chtOnEnabledChanging,TMethod(OnEnabledChangingEvent));
|
|
end;
|
|
|
|
procedure TControl.AddHandlerOnEnabledChanged(const OnEnabledChangedEvent: TNotifyEvent;
|
|
AsFirst: Boolean);
|
|
begin
|
|
AddHandler(chtOnEnabledChanged,TMethod(OnEnabledChangedEvent),AsFirst);
|
|
end;
|
|
|
|
procedure TControl.RemoveHandlerOnEnabledChanged(
|
|
const OnEnabledChangedEvent: TNotifyEvent);
|
|
begin
|
|
RemoveHandler(chtOnEnabledChanged,TMethod(OnEnabledChangedEvent));
|
|
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.AddHandlerOnBeforeDestruction(const OnBeforeDestructionEvent: TNotifyEvent; AsFirst: Boolean);
|
|
begin
|
|
AddHandler(chtOnBeforeDestruction,TMethod(OnBeforeDestructionEvent));
|
|
end;
|
|
|
|
procedure TControl.RemoveHandlerOnBeforeDestruction(
|
|
const OnBeforeDestructionEvent: TNotifyEvent);
|
|
begin
|
|
RemoveHandler(chtOnBeforeDestruction,TMethod(OnBeforeDestructionEvent));
|
|
end;
|
|
|
|
procedure TControl.AddHandlerOnMouseWheel(const OnMouseWheelEvent: TMouseWheelEvent; AsFirst: Boolean);
|
|
begin
|
|
AddHandler(chtOnMouseWheel,TMethod(OnMouseWheelEvent),AsFirst);
|
|
end;
|
|
|
|
procedure TControl.RemoveHandlerOnMouseWheel(
|
|
const OnMouseWheelEvent: TMouseWheelEvent);
|
|
begin
|
|
RemoveHandler(chtOnMouseWheel,TMethod(OnMouseWheelEvent));
|
|
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(0);
|
|
|
|
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;
|
|
// explicit notification about component destruction. this can be a drag target
|
|
DragManager.Notification(Self, opRemove);
|
|
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 Assigned(FHostDockSite) and Assigned(FHostDockSite.FDockClients) 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);
|
|
FreeThenNil(FAccessibleObject);
|
|
//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;
|
|
|
|
procedure TControl.BeforeDestruction;
|
|
begin
|
|
inherited BeforeDestruction;
|
|
DoCallNotifyHandler(chtOnBeforeDestruction);
|
|
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)
|
|
FAccessibleObject := CreateAccessibleObject();
|
|
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);
|
|
|
|
FBaseBounds.Right := -1;
|
|
FAnchors := [akLeft,akTop];
|
|
FAlign := alNone;
|
|
FCaptureMouseButtons := [mbLeft];
|
|
FColor := {$ifdef UseCLDefault}clDefault{$else}clWindow{$endif};
|
|
FVisible := True;
|
|
FParentBidiMode := True;
|
|
FParentColor := True;
|
|
FParentFont := True;
|
|
FDesktopFont := 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(sParentRequired, [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;
|
|
begin
|
|
Result := False;
|
|
while Assigned(AControl) do
|
|
begin
|
|
AControl := AControl.Parent;
|
|
if Self = AControl then
|
|
Exit(True);
|
|
end;
|
|
end;
|
|
|
|
function TControl.GetTopParent: TControl;
|
|
begin
|
|
Result := Self;
|
|
while Assigned(Result.Parent) do
|
|
Result := Result.Parent;
|
|
end;
|
|
|
|
function TControl.FindSubComponent(AName: string): TComponent;
|
|
// Like TComponent.FindComponent but finds also a subcomponent which name is
|
|
// separated by a dot. For example 'LabeledEdit1.SubLabel'.
|
|
var
|
|
i: Integer;
|
|
SubName: String;
|
|
begin
|
|
i := Pos('.', AName);
|
|
if i > 0 then begin
|
|
SubName := Copy(AName, i+1, Length(AName));
|
|
Delete(AName, i, Length(AName));
|
|
end
|
|
else
|
|
SubName := '';
|
|
Result := FindComponent(AName);
|
|
if Assigned(Result) and (SubName<>'') then
|
|
Result := Result.FindComponent(SubName);
|
|
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: TSpacingSize;
|
|
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: TSpacingSize;
|
|
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: TSpacingSize; 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: TSpacingSize);
|
|
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: TSpacingSize);
|
|
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.GetCanvasScaleFactor: Double;
|
|
begin
|
|
Result := TWSControlClass(WidgetSetClass).GetCanvasScaleFactor(Self);
|
|
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 := Scale96ToFont(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 := Scale96ToFont(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 := Scale96ToFont(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 := Scale96ToFont(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.GetSidePosition;
|
|
|
|
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;
|
|
|
|
procedure RaiseLoop;
|
|
begin
|
|
raise ELayoutException.Create('TControl.InvalidatePreferredSize loop detected '+DbgSName(Self)+' Bounds='+dbgs(BoundsRect));
|
|
end;
|
|
|
|
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;
|
|
if (AControl.Parent=nil)
|
|
and (cfKillInvalidatePreferredSize in AControl.FControlFlags)
|
|
then
|
|
RaiseLoop;
|
|
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;
|
|
s: String;
|
|
begin
|
|
i:=FAutoSizingLockReasons.Count-1;
|
|
while i>=0 do begin
|
|
if FAutoSizingLockReasons[i]=Reason then begin
|
|
FAutoSizingLockReasons.Delete(i);
|
|
exit;
|
|
end;
|
|
dec(i);
|
|
end;
|
|
s:='TControl.EnableAutoSizing '+DbgSName(Self)+' never disabled with reason "'+Reason+'"';
|
|
for i:=0 to FAutoSizingLockReasons.Count-1 do
|
|
s+=','+LineEnding+'reason['+IntToStr(i)+']="'+FAutoSizingLockReasons[i]+'"';
|
|
RaiseGDBException(s);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
begin
|
|
{$IFDEF DebugDisableAutoSizing}
|
|
CheckReason;
|
|
{$ENDIF}
|
|
if FAutoSizingLockCount<=0 then
|
|
raise ELayoutException.CreateFmt('TControl.EnableAutoSizing %s: missing DisableAutoSizing',
|
|
[DbgSName(Self)]);
|
|
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}
|
|
//DebugLn(Format('Trace:[TWinControl.WMSize] %s', [ClassName]));
|
|
|
|
if Assigned(Parent) 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 Assigned(Parent) 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{$IFDEF DebugDisableAutoSizing}('TControl.SetBiDiMode'){$ENDIF};
|
|
try
|
|
Perform(CM_BIDIMODECHANGED, 0, 0); // see TWinControl.CMBiDiModeChanged
|
|
finally
|
|
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetBiDiMode'){$ENDIF};
|
|
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;
|
|
|
|
procedure TControl.CMChanged(var Message: TLMessage);
|
|
begin
|
|
if FParent<>nil then
|
|
FParent.WindowProc(Message);
|
|
end;
|
|
|
|
procedure TControl.CMSysFontChanged(var Message: TLMessage);
|
|
begin
|
|
if FDesktopFont then
|
|
begin
|
|
Font := Screen.SystemFont;
|
|
FDesktopFont := True;
|
|
end;
|
|
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
|