Welcome to OStack Knowledge Sharing Community for programmer and developer-Open, Learning and Share
Welcome To Ask or Share your Answers For Others

Categories

0 votes
981 views
in Technique[技术] by (71.8m points)

delphi - How to copy the properties of one class instance to another instance of the same class?

I want to duplicate a class. It is sufficient that I copy all properties of that class. Is it possible to:

  1. loop thru all properties of a class?
  2. assign each property to the other property, like a.prop := b.prop?

The getters and setters should take care of the underlying implementation details.

EDIT: As Francois pointed out I did not word my question carefully enough. I hope the new wording of the question is better

SOLUTION: Linas got the right solution. Find a small demo program below. Derived classes work as expected. I didn't know about the new RTTI possibilities until several people pointed me at it. Very useful information. Thank you all.

  unit properties;

  interface

  uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
       Dialogs, StdCtrls,
       RTTI, TypInfo;

  type
     TForm1 = class(TForm)
        Memo1: TMemo;
        Button0: TButton;
        Button1: TButton;

        procedure Button0Click(Sender: TObject);
        procedure Button1Click(Sender: TObject);

     public
        procedure GetObjectProperties (AObject: TObject; AList: TStrings);
        procedure CopyObject<T: class>(ASourceObject, ATargetObject: T);
     end;

     TDemo = class (TObject)
     private
        FIntField: Int32;

        function  get_str_field: string;
        procedure set_str_field (value: string);

     public
        constructor Create; virtual;

        property IntField: Int32 read FIntField write FIntField;
        property StrField: string read get_str_field write set_str_field;
     end; // Class: TDemo //

     TDerived = class (TDemo)
     private
        FList: TStringList;

        function  get_items: string;
        procedure set_items (value: string);

     public
        constructor Create; override;
        destructor Destroy; override;
        procedure add_string (text: string);

        property Items: string read get_items write set_items;
     end;

  var Form1: TForm1;

  implementation

  {$R *.dfm}

  procedure TForm1.GetObjectProperties(AObject: TObject; AList: TStrings);
  var ctx: TRttiContext;
      rType: TRttiType;
      rProp: TRttiProperty;
      AValue: TValue;
      sVal: string;

  const SKIP_PROP_TYPES = [tkUnknown, tkInterface];

  begin
     if not Assigned(AObject) and not Assigned(AList) then Exit;

     ctx := TRttiContext.Create;
     rType := ctx.GetType(AObject.ClassInfo);
     for rProp in rType.GetProperties do
     begin
        if (rProp.IsReadable) and not (rProp.PropertyType.TypeKind in SKIP_PROP_TYPES) then
        begin
           AValue := rProp.GetValue(AObject);
           if AValue.IsEmpty then
           begin
              sVal := 'nil';
           end else
           begin
              if AValue.Kind in [tkUString, tkString, tkWString, tkChar, tkWChar]
                 then sVal := QuotedStr(AValue.ToString)
                 else sVal := AValue.ToString;
           end;
           AList.Add(rProp.Name + '=' + sVal);
        end;
     end;
  end;

  procedure TForm1.CopyObject<T>(ASourceObject, ATargetObject: T);
  const
    SKIP_PROP_TYPES = [tkUnknown, tkInterface, tkClass, tkClassRef, tkPointer, tkProcedure];
  var
    ctx: TRttiContext;
    rType: TRttiType;
    rProp: TRttiProperty;
    AValue, ASource, ATarget: TValue;
  begin
    Assert( Assigned(ASourceObject) and Assigned(ATargetObject) , 'Both objects must be assigned');
    ctx := TRttiContext.Create;
    rType := ctx.GetType(ASourceObject.ClassInfo);
    ASource := TValue.From<T>(ASourceObject);
    ATarget := TValue.From<T>(ATargetObject);

    for rProp in rType.GetProperties do
    begin
      if (rProp.IsReadable) and (rProp.IsWritable) and not (rProp.PropertyType.TypeKind in SKIP_PROP_TYPES) then
      begin
        //when copying visual controls you must skip some properties or you will get some exceptions later
        if SameText(rProp.Name, 'Name') or (SameText(rProp.Name, 'WindowProc')) then
          Continue;
        AValue := rProp.GetValue(ASource.AsObject);
        rProp.SetValue(ATarget.AsObject, AValue);
      end;
    end;
  end;

  procedure TForm1.Button0Click(Sender: TObject);
  var demo1, demo2: TDemo;
  begin
     demo1 := TDemo.Create;
     demo2 := TDemo.Create;
     demo1.StrField := '1023';

     Memo1.Lines.Add ('---Demo1---');
     GetObjectProperties (demo1, Memo1.Lines);
     CopyObject<TDemo> (demo1, demo2);

     Memo1.Lines.Add ('---Demo2---');
     GetObjectProperties (demo2, Memo1.Lines);
  end;

  procedure TForm1.Button1Click(Sender: TObject);
  var derivate1, derivate2: TDerived;
  begin
     derivate1 := TDerived.Create;
     derivate2 := TDerived.Create;
     derivate1.IntField := 432;
     derivate1.add_string ('ien');
     derivate1.add_string ('twa');
     derivate1.add_string ('drei');
     derivate1.add_string ('fjour');

     Memo1.Lines.Add ('---derivate1---');
     GetObjectProperties (derivate1, Memo1.Lines);
     CopyObject<TDerived> (derivate1, derivate2);

     Memo1.Lines.Add ('---derivate2---');
     GetObjectProperties (derivate2, Memo1.Lines);
  end;

  constructor TDemo.Create;
  begin
     IntField := 321;
  end; // Create //

  function TDemo.get_str_field: string;
  begin
     Result := IntToStr (IntField);
  end; // get_str_field //

  procedure TDemo.set_str_field (value: string);
  begin
     IntField := StrToInt (value);
  end; // set_str_field //

  constructor TDerived.Create;
  begin
     inherited Create;

     FList := TStringList.Create;
  end; // Create //

  destructor TDerived.Destroy;
  begin
     FList.Free;

     inherited Destroy;
  end; // Destroy //

  procedure TDerived.add_string (text: string);
  begin
     FList.Add (text);
  end; // add_string //

  function TDerived.get_items: string;
  begin
     Result := FList.Text;
  end; // get_items //

  procedure TDerived.set_items (value: string);
  begin
     FList.Text := value;
  end; // set_items //

  end. // Unit: properties //
See Question&Answers more detail:os

与恶龙缠斗过久,自身亦成为恶龙;凝视深渊过久,深渊将回以凝视…
Welcome To Ask or Share your Answers For Others

1 Answer

0 votes
by (71.8m points)

Try this code (but I won't advise copying properties of visual components because then you'll need to manually skip some properties):

uses
  Rtti, TypInfo;

procedure CopyObject<T: class>(ASourceObject, ATargetObject: T);

procedure TForm1.CopyObject<T>(ASourceObject, ATargetObject: T);
const
  SKIP_PROP_TYPES = [tkUnknown, tkInterface, tkClass, tkClassRef, tkPointer, tkProcedure];
var
  ctx: TRttiContext;
  rType: TRttiType;
  rProp: TRttiProperty;
  AValue, ASource, ATarget: TValue;
begin
  Assert( Assigned(ASourceObject) and Assigned(ATargetObject) , 'Both objects must be assigned');
  ctx := TRttiContext.Create;
  rType := ctx.GetType(ASourceObject.ClassInfo);
  ASource := TValue.From<T>(ASourceObject);
  ATarget := TValue.From<T>(ATargetObject);

  for rProp in rType.GetProperties do
  begin
    if (rProp.IsReadable) and (rProp.IsWritable) and not (rProp.PropertyType.TypeKind in SKIP_PROP_TYPES) then
    begin
      //when copying visual controls you must skip some properties or you will get some exceptions later
      if SameText(rProp.Name, 'Name') or (SameText(rProp.Name, 'WindowProc')) then
        Continue;
      AValue := rProp.GetValue(ASource.AsObject);
      rProp.SetValue(ATarget.AsObject, AValue);
    end;
  end;
end;

Usage example:

CopyObject<TDemoObj>(FObj1, FObj2);

与恶龙缠斗过久,自身亦成为恶龙;凝视深渊过久,深渊将回以凝视…
Welcome to OStack Knowledge Sharing Community for programmer and developer-Open, Learning and Share
Click Here to Ask a Question

...