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

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

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

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のデータ型の列挙が微妙に違っているので
そのマッピングを少々強引に行ってます。

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

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型の定義は以下のとおりです。

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.