Delphiの面倒なこと
Delphiでアプリを作るときに環境設定データをクラスTPersistentを継承して作るかと思います。クラスの例として色々なデータ型を内部に持つクラスを定義します。
testdata.pas
type
TTestClass = class(TPersistent)
private
{ Private 宣言 }
FVInt: Integer;
FVStr: string;
FVBool: Boolean;
FVDouble: Double;
FVInt64: Int64;
FVSet: TTestSet;
FVColor: TColor;
FVFontStyle: TFontStyles;
FVDate: TDateTime;
FVComp: TTestCompSub;
FVFont: TFont;
FVValiant: Variant;
FVType: TTestType;
public
{ Public 宣言 }
procedure Assign(Source : TPersistent);override;
published
property VInt : Integer read FVInt write FVInt default 1;
property VStr : string read FVStr write FVStr;
property VBool : Boolean read FVBool write FVBool;
property VDouble : Double read FVDouble write FVDouble;
property VInt64 : Int64 read FVInt64 write FVInt64;
property VColor : TColor read FVColor write FVColor;
property VDate : TDateTime read FVDate write FVDate;
property VFont : TFont read FVFont write FVFont;
property VValiant : Variant read FVValiant write FVValiant;
end;
何も考えずに publishedを使っていますがコンポーネントとして実装しない限り publictと特に挙動は変わりません。※実際は全然違うのですが
こうやって作ったTTestClass型の実体 aFrom,aToを生成してaFromに値を代入します。
このaFromをaToにクラスごと代入する場合に Assignを実装します
assign.pas
var
aFrom,aTo : TTestClass;
begin
aFrom := TTestClass.Create(Self);
aTo := TTestClass.Create(Self);
aFrom.FVInt := 1;
aFrom.FVStr := s;
aFrom.FVDouble := 12.34;
aFrom.FVInt64 := 123456789;
aFrom.FVBool := True;
aFrom.FVColor := $123456;
aFrom.FVDate := Now;
aFrom.FVFontStyle := [fsBold];
aFrom.VValiant := 1.1;
aTo.Assign(aFrom);
aTo.Free;
aFrom.Free;
end;
procedure TTestClass.Assign(Source: TPersistent);
var
a : TTestClass;
begin
if Source is TDataConfig then begin
a := TTestClass(Source);
FVInt := a.FVInt;
FVStr := a.FVStr;
FVDouble := a.FVDouble;
FVInt64 := a.FVInt64;
FVBool := a.FVBool;
FVColor := a.FVColor;
FVDate := a.FVDate;
FVFontStyle := a.FVFontStyle;
FVValiant := a.FVValiant;
end
else begin
inherited;
end;
end;
これが1回や2回ならまだしも、データクラスを作るたびに Assignを実装して手動で代入処理を書かなければなりません。
そのためデータ設計に時間がかかり肝心のプログラムの開発時間が短くなります。
これを自動で代入しようというのが今回紹介するプログラムです。
実装方法
クラスの定義があるファイルをインクルードしたらこのように変更します
変更前.pas
type
TTestClass = class(TPersistent)
private
変更後.pas
type
TTestClass = class(TPersistentEx)
private
たったこれだけで自動的に代入が出来るようになります。
仕組み
Delphiのpublished節に定義した変数は実行時型情報RTTIを持つのでこれを利用して代入を行うだけです。
仕組みは簡単ですがプログラムは膨大です。
TStringListには便利なValuesプロパティがありこれを使うと「キー」と「値」を管理する文字列リストを作る事が出来ます。
test.ini
VInt=1234;
VStr='abcd';
VBool=1;
しかしこのまま使うと存在しないキーを読み込んでエラーになったり変数の型ごとに読み書きが出来ないのでこれを拡張します。
StringListEx.pas
StringListEx.pas
unit StringListEx;
interface
uses
Windows,Messages, SysUtils, Classes, Graphics, Controls,StdCtrls, ExtCtrls;
type
TStringListEx = class(TStringList)
private
{ Private 宣言 }
function GetCommaTextEx: string;
procedure SetCommaTextEx(const Value: string);
function CommaToMarkText(const str : string) : string;
function MarkTextToComma(const str : string) : string;
public
{ Public 宣言 }
property CommaTextEx : string read GetCommaTextEx write SetCommaTextEx;
function GetInt() : Integer;
function GetStr() : string;
function GetColor() : TColor;
function GetBool() : Boolean;
function GetDateTime() : TDateTime;
procedure SetInt(Value : Integer;Len : Integer = 0);
procedure SetStr(Value : string;Len : Integer = 0);
procedure SetBool(Value : Boolean);
procedure SetDateTime(Value : TDateTime);
function GetDateTimes(str : string;aDef : TDateTime) :TDateTime;
procedure SetDateTimes(str : string;const Value : TDateTime);
function GetStrs(str : string;aDef : string='') : string;
procedure SetStrs(str : string;const Value : string);
function GetInts(str : string;aDef : Integer=0) : Integer;
procedure SetInts(str : string;const Value : Integer);
function GetBools(str : string;aDef : Boolean=False) : Boolean;
procedure SetBools(str : string;const Value : Boolean);
function GetStrTblIndex(str : string;Tbl : array of string;aDef : Integer) : Integer;
function GetFloat() : Double;
function GetFloats(str : string;aDef : Double=0) : Double;
procedure SetFloat(Value : Double);
procedure SetFloats(str : string;Value : Double);
function GetHexs(str : string;aDef : Integer=0) : Integer;
procedure SetHexs(str : string;const Value,Digits : Integer);
end;
implementation
{ TDataSetubiStringListEx }
function TStringListEx.CommaToMarkText(const str: string): string;
var
s : string;
begin
s := str;
s :=StringReplace(s,'&','&a',[rfreplaceall]);
s :=StringReplace(s,',','&c',[rfreplaceall]);
s :=StringReplace(s,#$0d#$0a,'&d',[rfreplaceall]);
result := s;
end;
function TStringListEx.GetBool: Boolean;
begin
result := StrToIntDef(Strings[0],0) <> 0;
Delete(0);
end;
function TStringListEx.GetColor: TColor;
begin
result := StringToColor(Trim(Strings[0]));
Delete(0);
end;
function TStringListEx.GetCommaTextEx: string;
var
i : Integer;
s : string;
begin
result := '';
if Count = 0 then exit;
s := CommaToMarkText(Strings[0]);
for i := 1 to Count-1 do begin
s := s + ',' + CommaToMarkText(Strings[i]);
end;
result := s;
end;
function TStringListEx.GetDateTime: TDateTime;
begin
result := StrToDateTime(Strings[0]);
Delete(0);
end;
function TStringListEx.GetDateTimes(str: string;
aDef: TDateTime): TDateTime;
var
s : string;
begin
result := aDef;
s := Trim(Values[str]);
if s = '' then exit;
result := StrToDateTime(s);
end;
function TStringListEx.GetInt: Integer;
begin
result := StrToIntDef(Trim(Strings[0]),-1);
Delete(0);
end;
function TStringListEx.GetStr: string;
begin
result := MarkTextToComma(Strings[0]);
Delete(0);
end;
function TStringListEx.GetStrs(str: string; aDef: string =''): string;
var
s : string;
begin
result := aDef;
s := Values[str];
if s = '' then exit;
result := s;
end;
function TStringListEx.GetInts(str: string; aDef: Integer): Integer;
var
s : string;
begin
result := aDef;
s := Values[str];
if s = '' then exit;
result := StrToIntDef(s,aDef);
end;
function TStringListEx.GetBools(str: string; aDef: Boolean): Boolean;
var
s : string;
begin
result := aDef;
s := Values[str];
if s = '' then exit;
result := Boolean(StrToIntDef(s,Integer(aDef)));
end;
function TStringListEx.MarkTextToComma(const str: string): string;
var
s : string;
begin
s := str;
s := StringReplace(s,'&d',#$0d#$0a,[rfreplaceall]);
s := StringReplace(s,'&c',',',[rfreplaceall]);
s := StringReplace(s,'&a','&',[rfreplaceall]);
result := s;
end;
procedure TStringListEx.SetBool(Value: Boolean);
begin
Add(IntToStr(Integer(Value)));
end;
procedure TStringListEx.SetCommaTextEx(const Value: string);
var
i : Integer;
s,m : string;
begin
Clear;
for i := 1 to Length(Value) do begin
m := Copy(Value,i,1);
if m = ',' then begin
Add(MarkTextToComma(s));
s := '';
end
else begin
s := s + m;
end;
end;
//if s <> '' then Add(s);
Add(MarkTextToComma(s));
end;
procedure TStringListEx.SetDateTime(Value: TDateTime);
begin
Add(DateTimeToStr(Value));
end;
procedure TStringListEx.SetDateTimes(str: string; const Value: TDateTime);
begin
Values[str] := DateTimeToStr(Value);
end;
procedure TStringListEx.SetInt(Value: Integer;Len : Integer = 0);
var
s,ss : string;
begin
if Len = 0 then begin
Add(IntToStr(Value));
end
else begin
ss := IntToStr(Len);
s := '%' + ss + '.' + ss + 'd';
s := Format(s,[Value]);
Add(s);
end;
end;
procedure TStringListEx.SetStr(Value: string;Len : Integer = 0);
var
s : string;
begin
s := CommaToMarkText(Value);
if Len = 0 then begin
Add(s);
end
else begin
s := s + StringOfChar(' ',Len);
s := Copy(s,1,Len);
Add(s);
end;
end;
procedure TStringListEx.SetStrs(str: string; const Value: string);
begin
Values[str] := Value;
end;
procedure TStringListEx.SetInts(str: string; const Value: Integer);
begin
Values[str] := IntToStr(Value);
end;
procedure TStringListEx.SetBools(str: string; const Value: Boolean);
begin
Values[str] := IntToStr(Integer(Value));
end;
function TStringListEx.GetStrTblIndex(str: string; Tbl: array of string;
aDef: Integer): Integer;
var
s : string;
i : Integer;
begin
result := aDef;
s := GetStrs(str,'');
for i := 0 to High(Tbl) do begin
if s = Tbl[i] then begin
result := i;
break;
end;
end;
end;
function TStringListEx.GetFloat: Double;
begin
result := StrToFloat(Strings[0]);
Delete(0);
end;
function TStringListEx.GetFloats(str: string; aDef: Double): Double;
var
s : string;
begin
result := aDef;
s := Values[str];
if s = '' then exit;
result := StrToFloatDef(s,aDef);
end;
function TStringListEx.GetHexs(str: string; aDef: Integer): Integer;
var
s : string;
begin
result := aDef;
s := Values[str];
if s = '' then exit;
result := StrToIntDef('$'+s,aDef);
end;
procedure TStringListEx.SetFloat(Value: Double);
begin
Add(FloatToStr(Value));
end;
procedure TStringListEx.SetFloats(str : string;Value: Double);
begin
Values[str] := Format('%3.2f',[Value]);
end;
procedure TStringListEx.SetHexs(str: string; const Value, Digits: Integer);
begin
Values[str] := IntToHex(Value,Digits)
end;
end.
次に1つの文字列リストに複数のクラスのデータも管理できるようにセクションを作ります。セクションを利用するとこのようになります
test.ini
[SectionA]
VInt=1234
VStr='abcd'
VBool=1
[SectionB]
VInt=5678
VStr='efgh'
VBool=0
セクション付きの文字列リストを扱うためにTStringListKeyを作ります
TStringListKey.pas
TStringListKey.pas
unit StringListKey;
interface
uses
Windows,Messages, SysUtils, Classes, Graphics, Controls,StdCtrls, ExtCtrls,
StringListEx;
//--------------------------------------------------------------------------//
// キーを管理するクラス //
//--------------------------------------------------------------------------//
type
TStringListKey = class(TPersistent)
private
{ Private 宣言 }
FKeys: TStringList; // キーの一覧
FValues: TList; // 内容の管理
function GetKeyValues(Key: string): TStringListEx;
public
{ Public 宣言 }
constructor Create;
destructor Destroy; override;
function LoadFromFile(const FileName: string) : Boolean;
function SaveToFile(const FileName: string) : Boolean;
procedure StringsToKeys(t : TStringList);
procedure KeysToStrings(t : TStringList);
procedure Add(Key : string;Value : TStringList);
procedure Delete(Key : string);
procedure Clear();
property Keys : TStringList read FKeys;
property Values[Key : string] : TStringListEx read GetKeyValues;
end;
implementation
{ TStringListKey }
constructor TStringListKey.Create;
begin
FKeys := TStringList.Create;
FValues := TList.Create;
end;
destructor TStringListKey.Destroy;
var
i : Integer;
begin
for i := 0 to FValues.Count - 1 do begin
TStringList(FValues[i]).Free
end;
FValues.Clear;
FValues.Free;
FKeys.Free;
inherited;
end;
function TStringListKey.GetKeyValues(Key: string): TStringListEx;
var
i : Integer;
begin
result := nil;
i := FKeys.IndexOf(Key);
if i < 0 then exit;
result := FValues[i];
end;
//**************************************************************************//
// ～ キーと値をTStringList形式に変換 ～ //
//**************************************************************************//
procedure TStringListKey.KeysToStrings(t: TStringList);
var
i,j : Integer;
t2 : TStringList;
s : string;
begin
t.Clear;
for i := 0 to FKeys.Count-1 do begin
t.Add('[' + FKeys[i] + ']');
t2 := TStringList(FValues[i]);
for j := 0 to t2.Count-1 do begin
s := t2[j];
t.Add(t2[j]);
end;
end;
s := t.Text;
s := s;
end;
//**************************************************************************//
// ～ TStringList形式からキーと値を作成 ～ //
//**************************************************************************//
procedure TStringListKey.StringsToKeys(t: TStringList);
var
s,sk : string;
i,j,k : Integer;
f : Boolean;
t2 : TStringListEx;
begin
Clear();
f := False;
j := 0;
for i := 0 to t.Count-1 do begin
s := t.Strings[i];
if Length(s) = 0 then continue;
if s[1] = '[' then begin
if Length(s) > 2 then begin
sk := Copy(s,2,Length(s)-2);
FKeys.Add(sk);
if f then begin
t2 := TStringListEx.Create;
for k := j to i-1 do begin
t2.Add(t[k]);
end;
FValues.Add(Pointer(t2));
end;
j := i + 1;
f := True;
end;
end;
end;
if f then begin
t2 := TStringListEx.Create;
t2.Clear;
for k := j to t.Count-1 do begin
t2.Add(t[k]);
end;
FValues.Add(Pointer(t2));
end;
end;
//**************************************************************************//
// ～ ファイルから読み込む ～ //
//**************************************************************************//
function TStringListKey.LoadFromFile(const FileName: string) : Boolean;
var
t : TStringList;
begin
t := TStringList.Create;
try
result := False;
t.LoadFromFile(FileName); // ファイルを読み込む
StringsToKeys(t); // キーと値との形式に変換
result := True;
finally
t.Free;
end;
end;
//**************************************************************************//
// ～ ファイルに書き込む ～ //
//**************************************************************************//
function TStringListKey.SaveToFile(const FileName: string) : Boolean;
var
t : TStringList;
begin
t := TStringList.Create;
try
result := False;
KeysToStrings(t); // StringList形式に変換
t.SaveToFile(FileName); // ファイルに書き込む
result := True;
finally
t.Free;
end;
end;
//**************************************************************************//
// //
// ～ 新しい値を追加 ～ //
// //
// - Input - Key : 追加するキー //
// Value : 追加する内容 //
// //
// - Output - なし //
// //
//**************************************************************************//
procedure TStringListKey.Add(Key: string; Value: TStringList);
var
i : Integer;
t : TStringListEx;
begin
i := FKeys.IndexOf(Key);
if i < 0 then begin
FKeys.Add(Key);
t := TStringListEx.Create;
t.Assign(Value);
FValues.Add(Pointer(t));
end
else begin
TStringList(FValues[i]).Assign(Value);
end;
end;
//**************************************************************************//
// ～ キーを削除 ～ //
//**************************************************************************//
procedure TStringListKey.Delete(Key: string);
var
i : Integer;
begin
i := FKeys.IndexOf(Key);
if i = -1 then exit;
FKeys.Delete(i);
TStringList(FValues[i]).Free;
FValues.Delete(i);
end;
//**************************************************************************//
// ～ 全てのキーと値を初期化 ～ //
//**************************************************************************//
procedure TStringListKey.Clear;
var
i : Integer;
begin
FKeys.Clear;
for i := 0 to FValues.Count - 1 do begin
TStringList(FValues[i]).Free
end;
FValues.Clear;
end;
end.
最後に実行時型情報を利用して保存や読み込みを行うクラスを実装します
StringListRtti
StringListRtti.pas
unit StringListRtti;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls,StringListEx,TypInfo;
type
TPersistentEx = class(TPersistent)
public
{ Public 宣言 }
procedure Assign(Source : TPersistent);override;
end;
//--------------------------------------------------------------------------//
// 拡張TPersistentクラス（DefinePropertiesメソッドの強制公開） //
//--------------------------------------------------------------------------//
type TStringListRttiPersistent = class(TPersistent);
//--------------------------------------------------------------------------//
// 実行時型情報を利用したオブジェクトの保存と読み込みするクラス //
//--------------------------------------------------------------------------//
type
// 型種類
TRttiType = (rtNormal,rtBoolean,rtImitation,rtComponent,rtClass,rtCollection,rtRootClass);
TStringListRtti = class(TStringListEx)
private
{ Private 宣言 }
FObject : TObject;
FInfo : PTypeInfo;
FData : PTypeData;
FProps : PPropList;
procedure GetRttiInfo();
function CheckRttiType(aProp : PPropInfo) : TRttiType;
function CheckImitationProperty(aObject : TObject) : Boolean;
procedure SaveToObjectNormal(i : Integer);
procedure LoadFromObjectNormal(i : Integer);
public
{ Public 宣言 }
// Key=Value 形式の文字列リストを指定されたオブジェクトの変数に書き込む
function LoadFromObject(aObject : TObject) : Boolean;
// 指定されたオブジェクトを解析して Key=Value形式の文字列リストにする
function SaveToObject(aObject : TObject) : Boolean;
end;
implementation
{ TStringListRtti }
function TStringListRtti.CheckImitationProperty(aObject: TObject): Boolean;
var
stm : TWriter;
m : TStringStream;
s : string;
begin
result := False;
if aObject = nil then exit;
m := TStringStream.Create(s);
stm := TWriter.Create(m,4096);
try
//result := False;
TStringListRttiPersistent(aObject).DefineProperties(stm);
stm.FlushBuffer;
m.Seek(0, soFromBeginning);
result := m.DataString <> '';
finally
m.Free;
stm.Free;
end;
end;
function TStringListRtti.CheckRttiType(aProp: PPropInfo): TRttiType;
var
PName : string;
begin
result := rtNormal;
PName := string(aProp.Name);
if (aProp.PropType^.Kind = tkClass) then begin
if (CheckImitationProperty(GetObjectProp(FObject,aProp))) then begin
// 偽プロパティの処理
result := rtImitation;
end
else if GetObjectProp(FObject,PName) <> nil then begin
// クラスの処理
if GetObjectProp(FObject,PName) is TComponent then begin
// TComponentからの派生クラスのとき
result := rtComponent;
end
else begin
// TComponent以外からの派生クラスのとき
result := rtClass;
end;
end;
end
else if aProp.PropType^.Name = 'Boolean' then begin
result := rtBoolean;
end;
end;
procedure TStringListRtti.GetRttiInfo;
begin
FInfo := FObject.ClassInfo;
FData := GetTypeData(FInfo);
GetMem(FProps,FData^.PropCount * SizeOf(PPropInfo));
GetPropInfos(FInfo,FProps);
end;
function TStringListRtti.LoadFromObject(aObject: TObject): Boolean;
var
i : Integer;
begin
FObject := aObject;
GetRttiInfo();
for i :=0 to FData^.PropCount-1 do begin
if not IsStoredProp(FObject,FProps^[i]) then Continue;
LoadFromObjectNormal(i);
end;
result := true;
end;
procedure TStringListRtti.LoadFromObjectNormal(i: Integer);
var
aStr : string;
aInt : Integer;
aInt64 : Int64;
aFloat : Double;
p : PPropInfo;
PName : string;
aByte : Byte;
begin
p := FProps[i];
PName := string(FProps^[i].Name);
case CheckRttiType(p) of
rtNormal: begin
case p.PropType^.Kind of
tkChar,
tkWChar,
tkInteger : begin
// Integer型の読み込み
aInt := GetInts(PName,0);
SetOrdProp(FObject,p,aInt);
end;
tkUString,
tkLString,
tkWString,
tkString : begin
// String型の読み込み
aStr := GetStrs(PName,'');
SetStrProp(FObject,p,aStr);
end;
tkFloat : begin
// Float型の読み込み
aFloat := GetFloats(PName,0);
SetFloatProp(FObject,p,aFloat);
end;
tkInt64 : begin
// Int64型の読み込み
aStr := GetStrs(PName,'');
aInt64 := StrToInt64Def(aStr,0);
SetInt64Prop(FObject,p,aInt64);
end;
tkEnumeration : begin
// 列挙型の読み込み
aByte := GetInts(PName,0);
SetOrdProp(FObject,p,aByte);
end;
tkSet : begin
// 集合型の読み込み
aInt := GetInts(PName,0);
SetOrdProp(FObject,p,aInt);
end;
end;
end;
rtBoolean : begin
// Boolean型の読み込み
aInt := GetInts(PName,0);
SetOrdProp(FObject,p,aInt);
end;
else begin
end;
end;
end;
function TStringListRtti.SaveToObject(aObject: TObject): Boolean;
var
i,aInt : Integer;
PName : string;
begin
FObject := aObject;
GetRttiInfo();
for i :=0 to FData^.PropCount-1 do begin
if not IsStoredProp(FObject,FProps^[i]) then Continue;
PName := string(FProps^[i].Name);
case CheckRttiType(FProps^[i]) of
rtNormal: SaveToObjectNormal(i);
rtBoolean : begin
// Boolean型の書き込み
aInt := GetOrdProp(FObject,PName);
SetInts(PName,aInt);
end;
end;
end;
result := True;
end;
procedure TStringListRtti.SaveToObjectNormal(i: Integer);
var
aStr : string;
aInt : Integer;
aInt64 : Int64;
aFloat : Double;
s,PName : string;
begin
PName := string(FProps^[i].Name);
case FProps^[i].PropType^.Kind of
tkChar,
tkWChar,
tkInteger : begin
// Integer型の書き込み
aInt := GetOrdProp(FObject,PName);
SetInts(PName,aInt);
end;
tkInt64 : begin
// Int64型の書き込み
aInt64 := GetInt64Prop(FObject,PName);
s := IntToStr(aInt64);
SetStrs(PName,s);
end;
tkString : begin
// 短い文字列型の書き込み
aStr := GetStrProp(FObject,PName);
SetStrs(PName,aStr);
end;
tkUString,
tkLString,
tkWString : begin
// 長い文字列型の書き込み
aStr := GetStrProp(FObject,PName);
SetStrs(PName,aStr);
end;
tkEnumeration : begin
// 列挙型の書き込み
aInt := GetOrdProp(FObject,PName);
SetInts(PName,aInt);
end;
tkSet : begin
// 集合型の書き込み
aInt := GetOrdProp(FObject,PName);
SetInts(PName,aInt);
end;
tkFloat : begin
// Float型の書き込み
aFloat := GetFloatProp(FObject,PName);
aStr := FloatToStr(aFloat);
SetStrs(PName,aStr);
end;
end;
end;
{ TPersistentEx }
procedure TPersistentEx.Assign(Source: TPersistent);
var
a : TPersistentEx;
tk : TStringListRtti;
begin
if Source is TPersistentEx then begin
a := TPersistentEx(Source);
tk := TStringListRtti.Create;
try
tk.SaveToObject(a);
tk.LoadFromObject(Self);
finally
tk.Free;
end;
end
else begin
inherited;
end;
end;
ダウンロード
注意事項
独自のクラスや変数の型によっては非対応です。
独自クラスを実装した場合は、Assignを継承してinheritedと独自クラスへのAssignを実装すれば対応出来ます。
制作者を勝手に名乗る以外は改変や配布など使用に制限はありません。
なにかあればコメントとかで対応しますが、これは20年前に作ったものなので思い出しながらになります。
おわりに
Assignの実装部分を見ると実は TStringListRttiを生成して SaveToObject、 LoadFromObject(Self)しているだけです。
たったこれだけでもうAssignを実装する必要がなくなるから不思議ですね。
TStringListRttiはTStringListを継承した文字列リストなのでファイルへの保存や読み込みも可能です。つまりデータの保存と復元も自動です。