paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-06 11:18:10 +02:00
Code Issues Packages Projects Releases Wiki Activity

ide: componenttree: change parent of non lcl components

Browse Source
This commit is contained in:
mattias 2022-12-30 18:20:10 +01:00
parent f480047750
commit 5d4e6e72e4
3 changed files with 219 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

123
components/ideintf/componenttreeview.pas
View File

@ -35,6 +35,8 @@ uses
type
TCTVGetImageIndexEvent = procedure(APersistent: TPersistent;
var AIndex: integer) of object;
TCTVParentAcceptsChildEvent = function(aParent, aChild, aLookupRoot: TPersistent): boolean of object;
TCTVSetParentEvent = procedure(aChild, aParent, aLookupRoot: TPersistent) of object;
// First 4 are ways to change ZOrder, zoDelete deletes a component.
TZOrderDelete = (zoToFront, zoToBack, zoForward, zoBackward, zoDelete);
@ -44,6 +46,8 @@ type
TComponentTreeView = class(TCustomTreeView)
private
FComponentList: TBackupComponentList;
FOnParentAcceptsChild: TCTVParentAcceptsChildEvent;
FOnSetParent: TCTVSetParentEvent;
FPropertyEditorHook: TPropertyEditorHook;
// Map of Root component -> TAVLTree of collapsed components.
FRoot2CollapasedMap: TPointerToPointerTree;
@ -104,6 +108,8 @@ type
property OnModified: TNotifyEvent read FOnModified write FOnModified;
property OnComponentGetImageIndex : TCTVGetImageIndexEvent
read FOnComponentGetImageIndex write FOnComponentGetImageIndex;
property OnParentAcceptsChild: TCTVParentAcceptsChildEvent read FOnParentAcceptsChild write FOnParentAcceptsChild;
property OnSetParent: TCTVSetParentEvent read FOnSetParent write FOnSetParent;
end;
implementation
@ -360,7 +366,14 @@ var
CompEditDsg: TComponentEditorDesigner;
NewIndex, AIndex: Integer;
ok: Boolean;
ParentObj: TObject;
aLookupRoot, aParent, aChild: TPersistent;
begin
if PropertyEditorHook<>nil then
aLookupRoot := PropertyEditorHook.LookupRoot
else
aLookupRoot := nil;
GetComponentInsertMarkAt(X, Y, Node, InsertType);
SetInsertMark(nil, tvimNone);
if InsertType in [tvimAsNextSibling, tvimAsPrevSibling] then
@ -377,9 +390,11 @@ begin
else
CompEditDsg := nil;
if TObject(ParentNode.Data) is TWinControl then
ParentObj:=TObject(ParentNode.Data);
if ParentObj is TWinControl then
begin
AContainer := TWinControl(ParentNode.Data);
// reparent lcl TControl(s)
AContainer := TWinControl(ParentObj);
SelNode := GetFirstMultiSelected;
while Assigned(SelNode) do
begin
@ -410,6 +425,7 @@ begin
else
if TObject(Node.Data) is TCollectionItem then
begin
// reorder collection item
ACollection := TCollectionItem(Node.Data).Collection;
ACollection.BeginUpdate;
case InsertType of
@ -442,6 +458,19 @@ begin
SelNode := SelNode.GetPrevMultiSelected;
end;
ACollection.EndUpdate;
end else if Assigned(OnSetParent) and (ParentObj is TPersistent) then begin
// default: reparent
aParent:=TPersistent(ParentObj);
SelNode := GetLastMultiSelected;
while Assigned(SelNode) do
begin
if (TObject(SelNode.Data) is TPersistent) then
begin
aChild:=TPersistent(TObject(SelNode.Data));
OnSetParent(aChild,aParent,aLookupRoot);
end;
SelNode := SelNode.GetPrevMultiSelected;
end;
end;
BuildComponentNodes(True);
end;
@ -454,16 +483,14 @@ var
Node: TTreeNode;
AnObject: TObject;
AControl: TControl absolute AnObject;
AContainer: TPersistent;
AcceptControl, AcceptContainer: Boolean;
aLookupRoot, AContainer: TPersistent;
InsertType: TTreeViewInsertMarkType;
ParentNode: TTreeNode;
aLookupRoot: TPersistent;
UserAccept: Boolean;
begin
//debugln('TComponentTreeView.DragOver START ',dbgs(Accept));
AcceptContainer := False;
AcceptControl := True;
Accept:=false;
AContainer := nil;
GetComponentInsertMarkAt(X, Y, Node, InsertType);
SetInsertMark(Node, InsertType);
@ -480,53 +507,53 @@ begin
if Assigned(ParentNode) and Assigned(ParentNode.Data) then
begin
AnObject := TObject(ParentNode.Data);
if (AnObject is TWinControl) then
if AnObject is TPersistent then
begin
if ControlAcceptsStreamableChildComponent(TWinControl(AControl),
TComponentClass(AnObject.ClassType),aLookupRoot)
then begin
AContainer := TPersistent(AnObject);
//DebugLn(['TComponentTreeView.DragOver AContainer=',DbgSName(AContainer)]);
AcceptContainer := True;
end;
end
else
if (AnObject is TCollection) then
begin
// it is allowed to move container items inside the container
AContainer := TPersistent(AnObject);
AcceptContainer := True;
AContainer:=TPersistent(AnObject);
end;
end;
if AcceptContainer then
//debugln(['TComponentTreeView.DragOver AContainer=',DbgSName(AContainer)]);
if AContainer<>nil then
begin
Node := GetFirstMultiSelected;
while Assigned(Node) and AcceptControl do
while Assigned(Node) do
begin
AnObject := TObject(Node.Data);
// don't allow to move ancestor components
if (AnObject is TComponent) and
(csAncestor in TComponent(AnObject).ComponentState) then break;
if (AnObject is TControl) then
if Assigned(OnParentAcceptsChild) and (AnObject is TPersistent) then
begin
if AnObject = AContainer then break;
if not (AContainer is TWinControl) then break;
//DebugLn(['TComponentTreeView.DragOver AControl=',DbgSName(AControl),' Parent=',DbgSName(AControl.Parent),' OldAccepts=',csAcceptsControls in AControl.Parent.ControlStyle]);
// check if new parent allows this control class
if not TWinControl(AContainer).CheckChildClassAllowed(AnObject.ClassType, False) then
//debugln(['TComponentTreeView.DragOver Child=',DbgSName(AnObject),' AContainer=',DbgSName(AContainer)]);
if not OnParentAcceptsChild(AContainer,TPersistent(AnObject),aLookupRoot) then
break;
// check if one of the parent of the container is the control itself
if AControl.IsParentOf(TWinControl(AContainer)) then break;
// do not move children of a restricted parent to another parent
// e.g. TPage of TPageControl
if (AControl.Parent <> nil) and (AControl.Parent <> AContainer) and
(not (csAcceptsControls in AControl.Parent.ControlStyle)) then
break;
end
else
end else begin
// default rules for components:
// don't allow to move ancestor components
if (AnObject is TComponent) and
(csAncestor in TComponent(AnObject).ComponentState) then break;
if (AnObject is TControl) then
begin
if AnObject = AContainer then break;
if not (AContainer is TWinControl) then break;
//DebugLn(['TComponentTreeView.DragOver AControl=',DbgSName(AControl),' Parent=',DbgSName(AControl.Parent),' OldAccepts=',csAcceptsControls in AControl.Parent.ControlStyle]);
// check if new parent allows this control class
if not TWinControl(AContainer).CheckChildClassAllowed(AnObject.ClassType, False) then
break;
// check if one of the parents of the container is the control itself
if AControl.IsParentOf(TWinControl(AContainer)) then break;
// do not move children of a restricted parent to another parent
// e.g. TPage of TPageControl
if (AControl.Parent <> nil) and (AControl.Parent <> AContainer) and
(not (csAcceptsControls in AControl.Parent.ControlStyle)) then
break;
end;
end;
if (AnObject is TCollectionItem) then
begin
// allow to reorder collection items
if AnObject = AContainer then break;
if not (AContainer is TCollection) then
break;
@ -535,15 +562,15 @@ begin
end;
Node := Node.GetNextMultiSelected;
end;
AcceptControl := (Node = nil);
Accept := (Node = nil);
end;
Accept := AcceptContainer and AcceptControl;
//debugln('TComponentTreeView.DragOver A ',dbgs(Accept));
inherited DragOver(Source, X, Y, State, Accept);
UserAccept:=Accept;
inherited DragOver(Source, X, Y, State, UserAccept);
if Assigned(OnDragOver) then
Accept:=UserAccept;
//debugln('TComponentTreeView.DragOver B ',dbgs(Accept));
Accept := AcceptContainer and AcceptControl and ((OnDragOver=nil) or Accept);
end;
procedure TComponentTreeView.DragCanceled;

24
components/ideintf/formeditingintf.pas
View File

@ -150,6 +150,8 @@ type
class procedure InitFormInstance({%H-}aForm: TComponent); virtual; // called after NewInstance, before constructor
class function GetDefaultSize: TPoint; virtual;
public
procedure InitComponent(AComponent, NewParent: TComponent; NewBounds: TRect); virtual;
procedure ChangeParent(AComponent, NewParent: TComponent); virtual;
procedure SetBounds(AComponent: TComponent; NewBounds: TRect); virtual;
procedure GetBounds(AComponent: TComponent; out CurBounds: TRect); virtual;
procedure SetFormBounds(RootComponent: TComponent; NewBounds, ClientRect: TRect); virtual;
@ -158,7 +160,8 @@ type
out ScrollOffset: TPoint); virtual;
function GetComponentOriginOnForm(AComponent: TComponent): TPoint; virtual;
function ComponentIsIcon({%H-}AComponent: TComponent): boolean; virtual;
function ParentAcceptsChild({%H-}Parent: TComponent; {%H-}Child: TComponentClass): boolean; virtual;
function ParentAcceptsChild({%H-}Parent: TComponent; {%H-}ChildClass: TComponentClass): boolean; virtual;
function ParentAcceptsChildComponent({%H-}Parent, {%H-}Child: TComponent): boolean; virtual;
function ComponentIsVisible({%H-}AComponent: TComponent): Boolean; virtual;
function ComponentIsSelectable({%H-}AComponent: TComponent): Boolean; virtual;
function ComponentAtPos(p: TPoint; MinClass: TComponentClass;
@ -167,7 +170,6 @@ type
function UseRTTIForMethods({%H-}aComponent: TComponent): boolean; virtual; // false = use sources
// events
procedure InitComponent(AComponent, NewParent: TComponent; NewBounds: TRect); virtual;
procedure Paint; virtual;
procedure KeyDown(Sender: TControl; var {%H-}Key: word; {%H-}Shift: TShiftState); virtual;
procedure KeyUp(Sender: TControl; var {%H-}Key: word; {%H-}Shift: TShiftState); virtual;
@ -230,6 +232,8 @@ type
procedure CreateChildComponentsFromStream(BinStream: TStream;
ComponentClass: TComponentClass; Root: TComponent;
ParentControl: TWinControl; NewComponents: TFPList); virtual; abstract;
function ParentAcceptsChild(Parent, Child, aLookupRoot: TComponent): boolean; virtual; abstract;
function ParentAcceptsChildClass(Parent: TComponent; ChildClass: TComponentClass; aLookupRoot: TComponent): boolean; virtual; abstract;
// ancestors
function GetAncestorLookupRoot(AComponent: TComponent): TComponent; virtual; abstract;
@ -692,9 +696,16 @@ begin
end;
function TDesignerMediator.ParentAcceptsChild(Parent: TComponent;
Child: TComponentClass): boolean;
ChildClass: TComponentClass): boolean;
begin
Result:=false;
Result:=true;
end;
function TDesignerMediator.ParentAcceptsChildComponent(Parent, Child: TComponent
): boolean;
begin
if (Parent=nil) or (Child=nil) then exit(false);
Result:=ParentAcceptsChild(Parent,TComponentClass(Child.ClassType));
end;
function TDesignerMediator.ComponentIsVisible(AComponent: TComponent): Boolean;
@ -786,6 +797,11 @@ begin
TDesignerMediator(AComponent).SetParentComponent(NewParent);
end;
procedure TDesignerMediator.ChangeParent(AComponent, NewParent: TComponent);
begin
TDesignerMediator(AComponent).SetParentComponent(NewParent);
end;
procedure TDesignerMediator.KeyDown(Sender: TControl; var Key: word;
Shift: TShiftState);
begin

133
ide/customformeditor.pp
View File

@ -81,6 +81,9 @@ type
): TAvlTreeNode;
procedure FrameCompGetCreationClass(Sender: TObject;
var NewComponentClass: TComponentClass);
function OnCompTree_ParentAcceptsChild(aParent, aChild,
aLookupRoot: TPersistent): boolean;
procedure OnCompTree_SetParent(aChild, aParent, aLookupRoot: TPersistent);
procedure OnPasWriterFindAncestor(Writer: TCompWriterPas;
aComponent: TComponent; const aName: string; var anAncestor,
aRootAncestor: TComponent);
@ -231,6 +234,9 @@ type
procedure CreateChildComponentsFromStream(BinStream: TStream;
ComponentClass: TComponentClass; Root: TComponent;
ParentControl: TWinControl; NewComponents: TFPList); override;
function ParentAcceptsChild(Parent, Child, aLookupRoot: TComponent): boolean; override;
function ParentAcceptsChildClass(Parent: TComponent;
ChildClass: TComponentClass; aLookupRoot: TComponent): boolean; override;
function FixupReferences(AComponent: TComponent): TModalResult;
procedure WriterFindAncestor({%H-}Writer: TWriter; Component: TComponent;
const {%H-}Name: string;
@ -1293,18 +1299,21 @@ var
var
NewSize: TPoint;
begin
if Mediator<>nil then exit;
MediatorClass:=GetDesignerMediatorClass(TComponentClass(NewComponent.ClassType));
if MediatorClass<>nil then
if Mediator=nil then
begin
Mediator:=MediatorClass.CreateMediator(nil,NewComponent);
if Mediator<>nil then
MediatorClass:=GetDesignerMediatorClass(TComponentClass(NewComponent.ClassType));
if MediatorClass<>nil then
begin
NewSize:=Mediator.GetDefaultSize;
NewWidth:=NewSize.X;
NewHeight:=NewSize.Y;
Mediator:=MediatorClass.CreateMediator(nil,NewComponent);
FreeMediator:=true;
end;
end;
if Mediator<>nil then
begin
NewSize:=Mediator.GetDefaultSize;
NewWidth:=NewSize.X;
NewHeight:=NewSize.Y;
end;
end;
procedure MediatorInitComponent;
@ -1634,6 +1643,81 @@ begin
Root,BinStream,ComponentClass,ParentControl,NewComponents);
end;
function TCustomFormEditor.ParentAcceptsChild(Parent, Child,
aLookupRoot: TComponent): boolean;
var
Mediator: TDesignerMediator;
AControl: TControl;
aComp: TComponent;
begin
Result:=false;
if (Parent=nil) or (Child=nil) or (aLookupRoot=nil) then
exit;
// don't allow to move ancestor components
if csAncestor in Child.ComponentState then
exit;
// check if one of the parents of the Parent is the Child itself
aComp:=Parent;
repeat
if aComp=Child then exit;
aComp:=aComp.GetParentComponent;
until aComp=nil;
// check mediator
Mediator:=GetDesignerMediatorByComponent(aLookupRoot);
if Mediator<>nil then
begin
if not Mediator.ParentAcceptsChildComponent(Parent,Child) then
exit;
end;
// check LCL rules
if Parent is TWinControl then
begin
if (not (csAcceptsControls in TWinControl(Parent).ControlStyle)) then
exit;
if not TWinControl(Parent).CheckChildClassAllowed(TComponentClass(Child.ClassType), False) then
exit;
end
else if Parent is TControl then begin
exit;
end;
if Child is TControl then
begin
// do not move children of a restricted parent to another parent
// e.g. TPage of TPageControl
AControl:=TControl(Child);
if (AControl.Parent <> nil) and (AControl.Parent <> Parent) and
(not (csAcceptsControls in AControl.Parent.ControlStyle)) then
exit;
end;
Result:=true;
end;
function TCustomFormEditor.ParentAcceptsChildClass(Parent: TComponent;
ChildClass: TComponentClass; aLookupRoot: TComponent): boolean;
var
Mediator: TDesignerMediator;
begin
Result:=false;
if (Parent=nil) or (ChildClass=nil) or (aLookupRoot=nil) then
exit;
Mediator:=GetDesignerMediatorByComponent(aLookupRoot);
if Mediator<>nil then
Result:=Mediator.ParentAcceptsChild(Parent,ChildClass)
else if Parent is TWinControl then
begin
if not TWinControl(Parent).CheckChildClassAllowed(ChildClass, False) then
exit;
end else if Parent is TControl then begin
exit;
end;
Result:=true;
end;
function TCustomFormEditor.FixupReferences(AComponent: TComponent): TModalResult;
begin
Result:=MainIDEInterface.DoFixupComponentReferences(AComponent,[]);
@ -2332,6 +2416,35 @@ begin
OnSelectFrame(Sender,NewComponentClass);
end;
function TCustomFormEditor.OnCompTree_ParentAcceptsChild(aParent, aChild,
aLookupRoot: TPersistent): boolean;
begin
Result:=(aParent is TComponent)
and (aChild is TComponent)
and (aLookupRoot is TComponent)
and ParentAcceptsChild(TComponent(aParent),TComponent(aChild),TComponent(aLookupRoot));
end;
procedure TCustomFormEditor.OnCompTree_SetParent(aChild, aParent,
aLookupRoot: TPersistent);
var
Mediator: TDesignerMediator;
ChildComp, OldParent: TComponent;
begin
if not (aChild is TComponent) then exit;
if not (aParent is TComponent) then exit;
if not (aLookupRoot is TComponent) then exit;
Mediator:=GetDesignerMediatorByComponent(TComponent(aLookupRoot));
if Mediator<>nil then
begin
ChildComp:=TComponent(aChild);
OldParent:=ChildComp.GetParentComponent;
Mediator.ChangeParent(ChildComp,TComponent(aParent));
if ChildComp.GetParentComponent<>OldParent then
OnObjectInspectorModified(Self);
end;
end;
procedure TCustomFormEditor.OnPasWriterFindAncestor(Writer: TCompWriterPas;
aComponent: TComponent; const aName: string; var anAncestor,
aRootAncestor: TComponent);
@ -2595,6 +2708,7 @@ begin
if FObj_Inspector<>nil then begin
FObj_Inspector.OnModified:=nil;
FObj_inspector.OnNodeGetImageIndex:= nil;
FObj_inspector.ComponentTree.OnParentAcceptsChild:=nil;
end;
FObj_Inspector:=AnObjectInspector;
@ -2602,10 +2716,11 @@ begin
if FObj_Inspector<>nil then begin
FObj_Inspector.OnModified:=@OnObjectInspectorModified;
FObj_inspector.OnNodeGetImageIndex:= @DoOnNodeGetImageIndex;
FObj_inspector.ComponentTree.OnParentAcceptsChild:=@OnCompTree_ParentAcceptsChild;
FObj_inspector.ComponentTree.OnSetParent:=@OnCompTree_SetParent;
end;
end;
procedure TCustomFormEditor.DoOnNodeGetImageIndex(APersistent: TPersistent;
var AImageIndex: integer);
var