Rttiを使ってClientDataSetを作ってみる

以前、Team JapanのブログにEmployeeクラスのインスタンスからInsert文を
生成するサンプルのポストがありましたが、ちょっと改良してTClientDataSetを
動的生成する例を書いてみた。（って使い道があるかちょっと疑問です。）

一応ソースは、こんな感じ

view plainprint?

1. unit Unit3;  
2.   
3. interface  
4.   
5. uses  
6. 　　DBClient;  
7.   
8.   type DataSetOperator = Record  
9.      function CreateDataSet(obj : TObject) : TClientDataSet;  
10.      function AddRecord(cds : TClientDataSet; obj : TObject) : Boolean;  
11.   End;  
12.   
13.   
14. implementation  
15.   
16. uses  
17.  Rtti,TypInfo, DB, SysUtils;  
18. { DataSetFactory }  
19.   
20. function DataSetOperator.AddRecord(cds: TClientDataSet; obj: TObject): Boolean;  
21. var  
22.  ctx    : TRttiContext;  
23.  rtp    : TRttiProperty;  
24.  rtps   : TArray<trttiproperty>;  
25. begin  
26.   
27.  ctx := TRttiContext.Create;  
28.   
29.  rtps := ctx.FindType(obj.UnitName + '.' + obj.ClassName).GetProperties;  
30.   cds.Append;  
31.  for rtp in rtps do  
32.  begin  
33.    cds.FieldByName(rtp.Name).Value := rtp.GetValue(obj).AsVariant;  
34.  end;  
35.   cds.UpdateRecord;  
36. end;  
37.   
38. function DataSetOperator.CreateDataSet(obj: TObject): TClientDataSet;  
39. var  
40.  ctx    : TRttiContext;  
41.  rtp    : TRttiProperty;  
42.  rtps   : TArray<trttiproperty>;  
43.  cds    : TClientDataSet;  
44.  ft     : TFieldType;  
45.   fn     : String;  
46.   ftSize : Integer;  
47.   //ftdf : TFieldDef;  
48. begin  
49.   
50.  cds := TClientDataSet.Create(nil);  
51.   
52.  ctx := TRttiContext.Create;  
53.   
54.  rtps := ctx.FindType(obj.UnitName + '.' + obj.ClassName).GetProperties;  
55.   
56.  for rtp in rtps do  
57.  begin  
58.    //ここがちょっとダサイかも  
59.      //DelphiのRTTIの型とDBの型のマッチング  
60.      ftSize := 0;  
61.      if CompareText(rtp.PropertyType.Name,'Integer') = 0 then ft := ftInteger;  
62.      if CompareText(rtp.PropertyType.Name,'String')  = 0 then  
63.      begin  
64.     ft := ftString;  
65.         ftSize := 50;  
66.      end;  
67.      if CompareText(rtp.PropertyType.Name,'TDateTime') = 0 then ft := ftDateTime;  
68.      if CompareText(rtp.PropertyType.Name,'Currency') = 0 then ft := ftCurrency;  
69.      //if CompareText(rtp.PropertyType.Name,'Currency') = 0 then ft := ftCurrency;  
70.   
71.      cds.FieldDefs.Add(rtp.Name,ft,ftSize);  
72.   
73.  end;  
74.   cds.CreateDataSet;  
75.   Result := cds;  
76.   //cds.FieldDefs.Add();  
77.   
78. end;  
79.   
80. end.  
81.   
82. </trttiproperty></trttiproperty>  

unit Unit3;

interface

uses
　　DBClient;

  type DataSetOperator = Record
     function CreateDataSet(obj : TObject) : TClientDataSet;
     function AddRecord(cds : TClientDataSet; obj : TObject) : Boolean;
  End;


implementation

uses
 Rtti,TypInfo, DB, SysUtils;
{ DataSetFactory }

function DataSetOperator.AddRecord(cds: TClientDataSet; obj: TObject): Boolean;
var
 ctx    : TRttiContext;
 rtp    : TRttiProperty;
 rtps   : TArray;
begin

 ctx := TRttiContext.Create;

 rtps := ctx.FindType(obj.UnitName + '.' + obj.ClassName).GetProperties;
  cds.Append;
 for rtp in rtps do
 begin
   cds.FieldByName(rtp.Name).Value := rtp.GetValue(obj).AsVariant;
 end;
  cds.UpdateRecord;
end;

function DataSetOperator.CreateDataSet(obj: TObject): TClientDataSet;
var
 ctx    : TRttiContext;
 rtp    : TRttiProperty;
 rtps   : TArray;
 cds    : TClientDataSet;
 ft     : TFieldType;
  fn     : String;
  ftSize : Integer;
  //ftdf : TFieldDef;
begin

 cds := TClientDataSet.Create(nil);

 ctx := TRttiContext.Create;

 rtps := ctx.FindType(obj.UnitName + '.' + obj.ClassName).GetProperties;

 for rtp in rtps do
 begin
   //ここがちょっとダサイかも
     //DelphiのRTTIの型とDBの型のマッチング
     ftSize := 0;
     if CompareText(rtp.PropertyType.Name,'Integer') = 0 then ft := ftInteger;
     if CompareText(rtp.PropertyType.Name,'String')  = 0 then
     begin
    ft := ftString;
        ftSize := 50;
     end;
     if CompareText(rtp.PropertyType.Name,'TDateTime') = 0 then ft := ftDateTime;
     if CompareText(rtp.PropertyType.Name,'Currency') = 0 then ft := ftCurrency;
     //if CompareText(rtp.PropertyType.Name,'Currency') = 0 then ft := ftCurrency;

     cds.FieldDefs.Add(rtp.Name,ft,ftSize);

 end;
  cds.CreateDataSet;
  Result := cds;
  //cds.FieldDefs.Add();

end;

end.

DBのデータ型の列挙とRTTIのデータ型の列挙が微妙に違っているので
そのマッピングを少々強引に行ってます。

で、上のユニットを利用する例が

view plainprint?

1. unit Unit1;  
2.   
3. interface  
4.   
5. uses  
6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
7.   Dialogs, StdCtrls, DB, Grids, DBGrids;  
8.   
9. type  
10.   TForm1 = class(TForm)  
11.     DBGrid1: TDBGrid;  
12.     DataSource1: TDataSource;  
13.     Button1: TButton;  
14.     procedure Button1Click(Sender: TObject);  
15.   private  
16.     { Private 宣言 }  
17.   public  
18.     { Public 宣言 }  
19.   end;  
20.   
21. var  
22.   Form1: TForm1;  
23.   
24. implementation  
25.   
26. uses Unit2, Unit3,DBClient;  
27.   
28. {$R *.dfm}  
29.   
30. procedure TForm1.Button1Click(Sender: TObject);  
31. var  
32.  Emp : TEmployee;  
33.    DF  : DataSetOperator;  
34.    cds : TClientDataSet;  
35. begin  
36.   
37.  Emp := TEmployee.Create;  
38.   
39.    cds := DF.CreateDataSet(Emp);  
40.    cds.Active := true;  
41.  DataSource1.DataSet := cds;  
42.    //DataSource1.DataSet.Active := true;  
43.   
44.    Emp.EmpNo := 2;  
45.    Emp.FirstName := 'OldTPFun';  
46.    Emp.LastName := 'Delphi';  
47.    Emp.HireDate := StrToDate('2009/10/07');  
48.    Emp.Salary := 100000.00;  
49.    DF.AddRecord(cds,Emp);  
50.   
51.    Emp.Free;  
52. end;  
53.   
54. end.  

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, DB, Grids, DBGrids;

type
  TForm1 = class(TForm)
    DBGrid1: TDBGrid;
    DataSource1: TDataSource;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses Unit2, Unit3,DBClient;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
 Emp : TEmployee;
   DF  : DataSetOperator;
   cds : TClientDataSet;
begin

 Emp := TEmployee.Create;

   cds := DF.CreateDataSet(Emp);
   cds.Active := true;
 DataSource1.DataSet := cds;
   //DataSource1.DataSet.Active := true;

   Emp.EmpNo := 2;
   Emp.FirstName := 'OldTPFun';
   Emp.LastName := 'Delphi';
   Emp.HireDate := StrToDate('2009/10/07');
   Emp.Salary := 100000.00;
   DF.AddRecord(cds,Emp);

   Emp.Free;
end;

end.

このプログラム上で使っているEmployee型の定義は以下のとおりです。

view plainprint?

1. unit Unit2;  
2.   
3. interface  
4.   
5.  type TEmployee = class  
6.    private  
7.     FEmpNo: Integer;  
8.     FFirstName: String;  
9.     FLastName: String;  
10.     FHireDate: TDateTime;  
11.     FSalary: Currency;  
12.     procedure SetEmpNo(const Value: Integer);  
13.     procedure SetFirstName(const Value: String);  
14.     procedure SetLastName(const Value: String);  
15.     procedure SetHireDate(const Value: TDateTime);  
16.     procedure SetSalary(const Value: Currency);  
17.    public  
18.     property EmpNo : Integer read FEmpNo write SetEmpNo;  
19.     property FirstName : String read FFirstName write SetFirstName;  
20.       property LastName : String read FLastName write SetLastName;  
21.       property HireDate : TDateTime read FHireDate write SetHireDate;  
22.       property Salary : Currency read FSalary write SetSalary;  
23.    end;  
24. implementation  
25.   
26. { TEmployee }  
27.   
28. procedure TEmployee.SetEmpNo(const Value: Integer);  
29. begin  
30.   FEmpNo := Value;  
31. end;  
32.   
33. procedure TEmployee.SetFirstName(const Value: String);  
34. begin  
35.   FFirstName := Value;  
36. end;  
37.   
38. procedure TEmployee.SetHireDate(const Value: TDateTime);  
39. begin  
40.   FHireDate := Value;  
41. end;  
42.   
43. procedure TEmployee.SetLastName(const Value: String);  
44. begin  
45.   FLastName := Value;  
46. end;  
47.   
48. procedure TEmployee.SetSalary(const Value: Currency);  
49. begin  
50.   FSalary := Value;  
51. end;  
52.   
53. end.  

unit Unit2;

interface

 type TEmployee = class
   private
    FEmpNo: Integer;
    FFirstName: String;
    FLastName: String;
    FHireDate: TDateTime;
    FSalary: Currency;
    procedure SetEmpNo(const Value: Integer);
    procedure SetFirstName(const Value: String);
    procedure SetLastName(const Value: String);
    procedure SetHireDate(const Value: TDateTime);
    procedure SetSalary(const Value: Currency);
   public
    property EmpNo : Integer read FEmpNo write SetEmpNo;
    property FirstName : String read FFirstName write SetFirstName;
      property LastName : String read FLastName write SetLastName;
      property HireDate : TDateTime read FHireDate write SetHireDate;
      property Salary : Currency read FSalary write SetSalary;
   end;
implementation

{ TEmployee }

procedure TEmployee.SetEmpNo(const Value: Integer);
begin
  FEmpNo := Value;
end;

procedure TEmployee.SetFirstName(const Value: String);
begin
  FFirstName := Value;
end;

procedure TEmployee.SetHireDate(const Value: TDateTime);
begin
  FHireDate := Value;
end;

procedure TEmployee.SetLastName(const Value: String);
begin
  FLastName := Value;
end;

procedure TEmployee.SetSalary(const Value: Currency);
begin
  FSalary := Value;
end;

end.