みなさんこんにちは。オブジェクトの published なプロパティを列挙する
ユニットです。



unit HPropUtils;

interface

uses
  SysUtils, Classes, TypInfo;

type
  TGetPropProc = procedure (Instance: TObject; pInfo: PPropInfo;
    tInfo: PTypeInfo) of Object;
(*
  EnumProperties が列挙するプロパティを受け取るためのメソッドの型宣言。
  tInfo: PTypeInfo は pInfo.PropType^ で取得出来るが、Ｄ２の場合は
  pInfo.PropType となるので、この型のメソッドを実装する都度
  {$IFDEF VER90} の判別を行う煩雑さを避けるため、EnumProperties で取得
  したものを受け取る仕様とする。
  Instance ... プロパティを所有するオブジェクトへの参照
  pInfo ...... pInfo.Name でプロパティの名前が取得出来る。
  tInfo ...... tInfo.Name で型の名前 ex TColor, String が
               tInfo.Kind で型の種類 ex tkClass, tkInteger が取得出来る
*)

procedure EnumProperties(Instance: TPersistent; TypeKinds: TTypeKinds;
  Proc: TGetPropProc);

procedure AssignProperties(Source, Dest: TPersistent; TypeKinds: TTypeKinds);

implementation

procedure EnumProperties(Instance: TPersistent; TypeKinds: TTypeKinds;
  Proc: TGetPropProc);
(*
  Instance の published & TypeKinds なプロパティを列挙する。
  そのプロパティが TPersistent なオブジェクトの場合は、再帰的に処理する。
  そのオブジェクトが TCollection の場合は、Items.Count のループで処理する。
  TypeKinds には扱いたい型のタイプを指定する
  [tkClass]           クラス型のプロパティのみ処理する
  tkAny               すべての型のプロパティ（イベントを含む）
  tkMethods           イベントに対するすべての型のプロパティ
  tkProperties        非イベントプロパティに対するすべての型
*)
var
  PropList: PPropList;
  tInfo: PTypeInfo;
  Count, I, J: Integer;
  PropInstance: TObject;
begin
  Count := GetPropList(Instance.ClassInfo, TypeKinds, nil);
  GetMem(PropList, Count * SizeOf(PPropInfo));
  try
    GetPropList(Instance.ClassInfo, TypeKinds, PropList);
    // PropList の各項目は PPropInfo
    for I := 0 to Count - 1 do
    begin
      {$IFDEF VER90}
      tInfo := PropList[I].PropType;
      {$ELSE}
      tInfo := PropList[I].PropType^;
      {$ENDIF}
      Proc(Instance, PropList[I], tInfo);
      if tInfo.Kind = tkClass then
      begin
        PropInstance := TObject(GetOrdProp(Instance, PropList[I]));
        if PropInstance is TPersistent then
        begin
          EnumProperties(TPersistent(PropInstance), TypeKinds, Proc);
          if PropInstance is TCollection then
            for J := 0 to TCollection(PropInstance).Count - 1 do
              EnumProperties(TCollection(PropInstance).Items[J], TypeKinds, Proc);
        end;
      end;
    end;
  finally
    FreeMem(PropList, Count * SizeOf(PPropInfo));
  end;
end;

procedure AssignProperties(Source, Dest: TPersistent; TypeKinds: TTypeKinds);
(*
  Source の published なプロパティ値を Dest へコピーする
  Source, Dest は同じ型か、Dest は Source から派生された型でなければ
  ならない。互換性の無い型のインスタンスを渡すと例外が発生する。
  TypeKinds にはコピーしたい型のタイプを指定する
  [tkClass, tkString] クラス型と文字列型のプロパティのみ処理する
  tkAny               すべての型のプロパティ（イベントを含む）
  tkMethods           イベントに対するすべての型のプロパティ
  tkProperties        非イベントプロパティに対するすべての型
*)
var
  PropList: PPropList;
  I, Count: Integer;
begin
  Count := GetPropList(Source.ClassInfo, TypeKinds, nil);
  GetMem(PropList, Count * SizeOf(PPropInfo));
  try
    GetPropList(Source.ClassInfo, TypeKinds, PropList);
    for I := 0 to Count - 1 do
      {$IFDEF VER90}
      case PropList[I].PropType.Kind of
      {$ELSE}
      case PropList[I].PropType^.Kind of
      {$ENDIF}
        tkFloat:
          SetFloatProp(
            Dest, PropList[I], GetFloatProp(Source, PropList[I]));
        tkInteger, tkChar, tkEnumeration, tkSet, tkClass:
          SetOrdProp(
            Dest, PropList[I], GetOrdProp(Source, PropList[I]));
        tkMethod:
          SetMethodProp(
            Dest, PropList[I], GetMethodProp(Source, PropList[I]));
        tkString:
          SetStrProp(
            Dest, PropList[I], GetStrProp(Source, PropList[I]));
        { ? tkArray, tkRecord, tkInterface, tkInt64, tkDynArray ? }
      end;
  finally
    FreeMem(PropList, Count * SizeOf(PPropInfo));
  end;
end;

end.

--------------------------------------------------------------------------------// 使い方その１
// ラベルの Caption を変更する（を）

procedure TForm1.SpeedButton4Click(Sender: TObject);
begin
  EnumProperties(Label5, tkProperties, GetPropProc);
end;

procedure TForm1.GetPropProc(Instance: TObject; pInfo: PPropInfo;
  tInfo: PTypeInfo);
begin
  if (Instance is TLabel) and (pInfo.Name = 'Caption') then
    SetStrProp(Instance, pInfo, 'hogehoge');
end;

--------------------------------------------------------------------------------// 使い方その２
// Editor1.View のプロパティ名が 'Select' ではない TEditorColor 型プロパティの
// BkColor, Color プロパティを更新する。 View.Colors の各プロパティと
// View.Brackets.Items の ItemColor の全部を一度に更新することが出来る

procedure TForm1.SpeedButton5Click(Sender: TObject);
begin
  EnumProperties(Editor1.View, [tkClass], UpdateEditorColor);
end;

procedure TForm1.UpdateEditorColor(Instance: TObject; pInfo: PPropInfo;
  tInfo: PTypeInfo);
var
  PropInstance: TObject;
  Info: PPropInfo;
begin
  // オブジェクト型プロパティの場合
  if tInfo.Kind = tkClass then
  begin
    // そのプロパティの実体を取得する
    PropInstance := TObject(GetOrdProp(Instance, pInfo));
    // 実体が TEditorColor で、プロパティ名が 'Select' でない場合
    if (PropInstance is TEditorColor) and
       (AnsiCompareText(pInfo.Name, 'Select') <> 0) then
    begin
      // 実体の 'BkColor' という名前のプロパティ情報を取得
      Info := GetPropInfo(PropInstance.ClassInfo, 'BkColor');
      // その情報を元に新しい値で更新
      SetOrdProp(PropInstance, Info, Longint(ColorGrid1.BackgroundColor));
      // 'Color' も同様に処理
      Info := GetPropInfo(PropInstance.ClassInfo, 'Color');
      SetOrdProp(PropInstance, Info, Longint(ColorGrid1.ForegroundColor));
    end;
  end;
end;
--------------------------------------------------------------------------------// 使い方その３
// Editor1 の総ての TFontStyles 型プロパティに fsItalic が入っているかどうかを判別する。

procedure TForm1.SpeedButton7Click(Sender: TObject);
begin
  FItalicFontStyle := False;
  EnumProperties(Editor1, tkProperties, GetFontStyles);
end;

procedure TForm1.GetFontStyles(Instance: TObject; pInfo: PPropInfo;
  tInfo: PTypeInfo);
begin
  if (AnsiCompareText(tInfo.Name, 'TFontStyles') = 0) and
     (fsItalic in TFontStyles(Byte(GetOrdProp(Instance, pInfo)))) then
    FItalicFontStyle := True;
end;
--------------------------------------------------------------------------------
                                                   本田勝彦
 


- FDELPHI  MES(16):玉石混淆みんなで作るSample蔵【見本蓄積】 01/04/23 -

Original document by 本田勝彦        氏 ID:(VYR01647)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。