Клонирование компонентов VCL

Embarcadero в FMX заботливо предусмотрело клонирование, которе иногда может приятно упростить жизнь разработчика. VCL же явного инструмента клонирования в run-time не предоставляет.

Для чего это может быть использованно? Конечно же для клонирования визуальных компонентов по шаблону. Приемущества и недостатки данного подхода я предпочту оставить для гуру.

Далее я просто приведу код и свои комментарии:

unit Clonable;  interface  uses   System.SysUtils, System.Classes, System.TypInfo, Vcl.Controls, StrUtils;  { extending } type   TClonable = class(TComponent)   private     procedure CopyComponentProp(Source, Target: TObject; aExcept: array of string);   public     function Clone(const AOwner: TComponent; aExcept: array of string): TComponent;   end;   implementation   procedure TClonable.CopyComponentProp(Source, Target: TObject; aExcept: array of string); var   I, Index: Integer;   PropName: string;   Source_PropList  , Target_PropList  : PPropList;   Source_NumProps  , Target_NumProps  : Word;   Source_PropObject, Target_PropObject: TObject;   { property list finder }   function FindProperty(const PropName: string; PropList: PPropList; NumProps: Word): Integer;   var     I: Integer;   begin     Result:= -1;     for I:= 0 to NumProps - 1 do       if CompareStr(PropList^[I]^.Name, PropName) = 0 then begin         Result:= I;         Break;       end;   end; begin   if not Assigned(Source) or not Assigned(Target) then Exit;   Source_NumProps:= GetTypeData(Source.ClassInfo)^.PropCount;   Target_NumProps:= GetTypeData(Target.ClassInfo)^.PropCount;   GetMem(Source_PropList, Source_NumProps * SizeOf(Pointer));   GetMem(Target_PropList, Target_NumProps * SizeOf(Pointer));   try     { property list }     GetPropInfos(Source.ClassInfo, Source_PropList);     GetPropInfos(Target.ClassInfo, Target_PropList);     for I:= 0 to Source_NumProps - 1 do begin       PropName:= Source_PropList^[I]^.Name;       if  (AnsiIndexText('None'  , aExcept                ) =  -1) and          ((AnsiIndexText(PropName, ['Name', 'Left', 'Top']) <> -1) or           (AnsiIndexText(PropName, aExcept                ) <> -1)) then Continue;       Index:= FindProperty(PropName, Target_PropList, Target_NumProps);       if Index = -1 then Continue; {no property found}       { compare types }       if Source_PropList^[I]^.PropType^.Kind <> Target_PropList^[Index]^.PropType^.Kind then         Continue;       case Source_PropList^[I]^.PropType^^.Kind of         tkClass:  begin                     Source_PropObject:= GetObjectProp(Source, Source_PropList^[I    ]);                     Target_PropObject:= GetObjectProp(Target, Target_PropList^[Index]);                     CopyComponentProp(Source_PropObject, Target_PropObject, ['None']);                   end;         tkMethod: SetMethodProp(Target, PropName, GetMethodProp(Source, PropName));       else SetPropValue(Target, PropName, GetPropValue(Source, PropName));       end;     end;   finally     FreeMem(Source_PropList);     FreeMem(Target_PropList);   end; end;   function IsUniqueGlobalNameProc(const Name: string): Boolean; begin   if Length(Name) = 0 then     Result := True   else     Result := Not Assigned(FindGlobalComponent(Name)); end;   function TClonable.Clone(const AOwner: TComponent; aExcept: array of string): TComponent; var   S: TStream;   SaveName: string;   Reader: TReader;   FSaveIsUniqueGlobalComponentName: TIsUniqueGlobalComponentName;   I: Integer;   Child: TComponent;   LComponent: TComponent; begin   { for simple compatible }   LComponent:=Self;   { register self type }   RegisterClass(TPersistentClass(LComponent.ClassType));   S := TMemoryStream.Create;   Result := nil;   try     { store }     SaveName := LComponent.Name;     Self.Name := '';     S.WriteComponent(LComponent);     LComponent.Name := SaveName;     S.Position := 0;     { load }     FSaveIsUniqueGlobalComponentName := IsUniqueGlobalComponentNameProc;     IsUniqueGlobalComponentNameProc := IsUniqueGlobalNameProc;     try       Reader := TReader.Create(S, 4096);       try         Result := TComponent(Reader.ReadRootComponent(nil));         if Assigned(AOwner) then           AOwner.InsertComponent(Result);       finally         Reader.Free;         if not Assigned(Result) then           Result := TComponentClass(LComponent.ClassType).Create(AOwner);       end;     finally       IsUniqueGlobalComponentNameProc := FSaveIsUniqueGlobalComponentName;     end;   finally     S.Free;   end;   {parent}   if (LComponent is TControl) and (LComponent as TControl).HasParent then     (Result as TControl).Parent:=(LComponent as TControl).Parent;   { copy propertys value }   CopyComponentProp(LComponent, Result, aExcept);   { childs }   if (LComponent is TWinControl) and ((LComponent as TWinControl).ControlCount > 0) then     for I := 0 to (LComponent as TWinControl).ControlCount - 1 do begin       Child:=       TClonable(         (LComponent as TWinControl).           Controls[I]).           Clone(LComponent, aExcept);       if (Child is TControl) then         (Child as TControl).Parent:=(Result as TWinControl);     end; end;  end. 

Пример использования:

procedure TForm1.Button1Click(Sender: TObject); var   Clone: TPanel; begin   Clone:=TPanel(TClonable(Panel1).Clone(Self, []));   Clone.Top:=Panel1.Top+Panel1.Height; end; 

Описание метода Clone класса TClonable:
function Clone(const AOwner: TComponent; aExcept: array of string): TComponent;

• AOwner: TComponent — новый владелец клонируемого компонента
• aExcept: array of string — массив строк, содержащий названия свойств (имеется ввиду PPropList) для исключения при копировании
• Result — ссылка на новый объект класса TComponent представляюая копию исходного объекта, свойтво Name пустое

На мой взгляд, реализация предоставляет удобный способ копирования компонентов: с предусмотренным механизмом копирования дочерних объектов, которые могут содержать наследники TWinControl; переназначением событий; возможностью исключать ненужные свойства.

Ни в коем случае не претендую на новшество, имею ввиду велосипед, надеюсь на то что не костыль =)