A support class for cloning component.

ComponentStream.pas

unit Sample;


interface

uses
	SysUtils, Classes, FMX.Controls;

type
  // 名前決定するためのイベント
  NamePrefixEvent = procedure (Sender : TObject; Target : TComponent; var NamePrefix : string) of object;

  IComponentStream = interface
	  function Clone(inOwner : TComponent = nil) : TComponent;
  end;

	TComponentStream = class(TInterfacedObject, IComponentStream)
	private
		FStream : TStream;
    FOnValidNamePrefix : NamePrefixEvent;

    procedure SetValidNamePrefix(inEvent : NamePrefixEvent);

    procedure RegisterChildClass(CloneOwner, Component: TComponent);
    procedure ModifyOwner(inOwner, inComponent : TComponent);
    procedure NotifyDefaultValidName(Sender : TObject; Target : TComponent; var NamePrefix : string);

    procedure SetValidName(Reader : TReader; Component : TComponent; var Name : string);
	public
		constructor Create; overload;
		constructor Create(inSrc, Root : TComponent); overload;
		destructor Destroy; override;

    procedure Initialize(inSrc, Root : TComponent);

	  function Clone(inOwner : TComponent = nil) : TComponent;

    // 名前決定するためのイベント
    property OnValidNamePrefix : NamePrefixEvent read FOnValidNamePrefix write SetValidNamePrefix;
	end;

  // Srcの内容をDestにコピーする
  function CopyComponent(Src : TComponent) : TComponent;

implementation

// Srcの内容をDestにコピーする
function CopyComponent(Src : TComponent) : TComponent;
var
  stream : TComponentStream;
begin
  stream := TComponentStream.Create(Src, nil);
  try
    Result := stream.Clone(Src.Owner);
  finally
    stream.Free;
  end;
end;

constructor TComponentStream.Create;
begin
  // デフォルトイベントのセット
  OnValidNamePrefix := NotifyDefaultValidName;
end;

constructor TComponentStream.Create(inSrc, Root : TComponent);
begin
  // デフォルトイベントのセット
  OnValidNamePrefix := NotifyDefaultValidName;

  Self.Initialize(inSrc, Root);
end;

procedure TComponentStream.Initialize(inSrc, Root : TComponent);
var
	tmpName : string;

  writer : TWriter;
begin
	tmpName := inSrc.Name;
	try
		Self.RegisterChildClass(inSrc, inSrc);

		FStream := TMemoryStream.Create;

    writer := TWriter.Create(FStream, 4096);
    try
      writer.Root := Root;
      writer.WriteSignature;
      writer.WriteComponent(inSrc);
    finally
      writer.Free;
    end;
    FStream.Position := 0;
	finally
		inSrc.Name := tmpName;
	end;
end;

procedure TComponentStream.SetValidNamePrefix(inEvent : NamePrefixEvent);
begin
  if Assigned(inEvent) then begin
    FOnValidNamePrefix := inEvent;
  end;
end;

procedure TComponentStream.NotifyDefaultValidName(Sender : TObject; Target : TComponent; var NamePrefix : string);
begin
  NamePrefix := Target.ClassName;
  Delete(NamePrefix, 1, 1);
end;

// コンポのクラスをシステムのリストに登録
procedure TComponentStream.RegisterChildClass(CloneOwner, Component: TComponent);
var
  child: TComponent;
begin
  if GetClass(Component.ClassName) = nil then begin
    RegisterClass(TPersistentClass(Component.ClassType));
  end;

  for child in Component do begin
    RegisterChildClass(CloneOwner, child);   // recursive call
  end;
end;

destructor TComponentStream.Destroy;
begin
	FStream.Free;
end;

// オーナーを変更する
procedure TComponentStream.ModifyOwner(inOwner, inComponent : TComponent);
begin
  if inOwner <> nil then begin
    // 元のOwnerを放棄する
    if inComponent.Owner <> nil then begin
      inComponent.Owner.RemoveComponent(inComponent);
    end;
    // Ownerを変更する
    inOwner.InsertComponent(inComponent);
  end;
end;

// http://forum.nifty.com/fdelphi/faq/00069.htmを参考にした
// TClipBoardも参考になる
function TComponentStream.Clone(inOwner : TComponent) : TComponent;
var
	reader : TReader;
  name : string;
begin
  FStream.Seek(0,0);
  reader := TReader.Create(FStream, 256);
  
  try
    reader.BeginReferences;
    
    reader.Parent := inOwner;
    reader.Root := inOwner;
	  reader.OnSetName := SetValidName;

    reader.ReadSignature;
    Result := Reader.ReadComponent(nil);

    reader.FixupReferences;
  finally
    reader.EndReferences;
    reader.Free;
  end;
  
  try
  	// オーナーに登録された名前と重複することを避けるため空にする
    Result.Name := '';
    ModifyOwner(inOwner, Result);

    // 重複しない名前に変更する
    Self.SetValidName(nil, Result, name);
    Result.Name := name;
  except
    Result.Free;
    raise;
  end;
end;

procedure TComponentStream.SetValidName(Reader : TReader; Component : TComponent; var Name : string);

  // できたコンポにデフォルトの名前をつける
  procedure SetValidName(Compo: TComponent);
  var NewName: string;
    i: integer;
    namePrefix : string;
  begin
    if Compo.Owner = nil then Exit;

    // ベースの名前を決定する
    if Assigned(OnValidNamePrefix) then begin
      OnValidNamePrefix(Self, Compo, namePrefix);
    end;

    if namePrefix = '' then begin
      // 名前を解決できなかった場合、Componentのクラス名を適用する
      NotifyDefaultValidName(Self, Compo, namePrefix);
    end;

    i := 0;
    repeat
      inc(i);
      NewName := Format('%s%d', [namePrefix, i]);
    until Compo.Owner.FindComponent(NewName) = nil;
    Name := NewName;
  end;

begin
  SetValidName(Component);
end;

end.

Usage.pas

// Add 'SomeControl' to 'SomeLayout'
procedure TMyForm.FormCreate(Sender: TObject);
var
  stream: IComponentStream;
  i: integer;
  child: TControl;
begin
  stream := TComponentStream.Create(Self.SomeControl, Self);

  for i := 1 to 11 do begin
    child := stream.Clone(Self) as TControl;
    child.Parent := Self.SomeLayout;
  end;
end;