Клонирование компонентов 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; переназначением событий; возможностью исключать ненужные свойства.

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

    Комментарии 3

      0
      А зачем восстанавливать копировать свойства Result через CopyComponentProp?
      вроде как TStream.WriteComponent/WriteComponent и так должны скопировать все свойства?
        0
        TStream.WriteComponent — записывает только published свойства.
          0
          Ну во первых не только паблишед свойства, но и ещё всё, что в DefineProperties определено. А во вторых а что, CopyComponentProp копирует не только паблишед свойства??

      Только полноправные пользователи могут оставлять комментарии. Войдите, пожалуйста.

      Самое читаемое