delphi - 使用 RTTI 加载 FireMonkey 风格的资源

Question

我正在尝试编写继承自 FMX TStyledControl 的类。当样式更新时，它会将样式资源对象加载到缓存。

我为带有自定义控件的包创建了项目组，并按照 Delphi 帮助中的描述测试 FMX HD 项目。安装包并将 TsgSlideHost 放在测试表单上后，我运行测试应用程序。它运行良好，但是当我关闭它并尝试重建包时，RAD Studio 会显示“rtl160.bpl 中的错误”或“无效的指针操作”。

TsgStyledControl 的 LoadToCacheIfNeeded 过程似乎有什么问题，但我不明白为什么。将 RTTI 与 FMX 样式或其他内容一起使用是否有任何限制？

TsgStyledControl 来源:

unit SlideGUI.TsgStyledControl;

interface

uses
  System.SysUtils, System.Classes, System.Types, FMX.Types, FMX.Layouts, FMX.Objects,
  FMX.Effects, System.UITypes, FMX.Ani, System.Rtti, System.TypInfo;

type
  TCachedAttribute = class(TCustomAttribute)
  private
    fStyleName: string;
  public
    constructor Create(const aStyleName: string);
    property StyleName: string read fStyleName;
  end;

  TsgStyledControl = class(TStyledControl)
  private
    procedure CacheStyleObjects;
    procedure LoadToCacheIfNeeded(aField: TRttiField);
  protected
    function FindStyleResourceAs<T: class>(const AStyleLookup: string): T;
    function GetStyleName: string; virtual; abstract;
    function GetStyleObject: TControl; override;
  public
    procedure ApplyStyle; override;
  published
    { Published declarations }
  end;

implementation

{ TsgStyledControl }

procedure TsgStyledControl.ApplyStyle;
begin
  inherited;
  CacheStyleObjects;
end;

procedure TsgStyledControl.CacheStyleObjects;
var
  ctx: TRttiContext;
  typ: TRttiType;
  fld: TRttiField;
begin
  ctx := TRttiContext.Create;
  try
    typ := ctx.GetType(Self.ClassType);
    for fld in typ.GetFields do
      LoadFromCacheIfNeeded(fld);
  finally
    ctx.Free
  end;
end;

function TsgStyledControl.FindStyleResourceAs<T>(const AStyleLookup: string): T;
var
  fmxObj: TFmxObject;
begin
  fmxObj := FindStyleResource(AStyleLookup);
  if Assigned(fmxObj) and (fmxObj is T) then
    Result := fmxObj as T
  else
    Result := nil;
end;

function TsgStyledControl.GetStyleObject: TControl;
var
  S: TResourceStream;
begin
  if (FStyleLookup = '') then
  begin
    if FindRCData(HInstance, GetStyleName) then
    begin
      S := TResourceStream.Create(HInstance, GetStyleName, RT_RCDATA);
      try
        Result := TControl(CreateObjectFromStream(nil, S));
        Exit;
      finally
        S.Free;
      end;
    end;
  end;
  Result := inherited GetStyleObject;
end;

procedure TsgStyledControl.LoadToCacheIfNeeded(aField: TRttiField);
var
  attr: TCustomAttribute;
  styleName: string;
  styleObj: TFmxObject;
  val: TValue;
begin
  for attr in aField.GetAttributes do
  begin
    if attr is TCachedAttribute then
    begin
      styleName := TCachedAttribute(attr).StyleName;
      if styleName <> '' then
      begin
        styleObj := FindStyleResource(styleName);
        val := TValue.From<TFmxObject>(styleObj);
        aField.SetValue(Self, val);
      end;
    end;
  end;
end;

{ TCachedAttribute }

constructor TCachedAttribute.Create(const aStyleName: string);
begin
  fStyleName := aStyleName;
end;

end.

TsgStyledControl 的使用:

type
  TsgSlideHost = class(TsgStyledControl)
  private
    [TCached('SlideHost')]
    fSlideHost: TLayout;
    [TCached('SideMenu')]
    fSideMenuLyt: TLayout;
    [TCached('SlideContainer')]
    fSlideContainer: TLayout;
    fSideMenu: IsgSideMenu;
    procedure ReapplyProps;
    procedure SetSideMenu(const Value: IsgSideMenu);
  protected
    function GetStyleName: string; override;
    function GetStyleObject: TControl; override;
    procedure UpdateSideMenuLyt;
  public
    constructor Create(AOwner: TComponent); override;
    procedure ApplyStyle; override;
  published
    property SideMenu: IsgSideMenu read fSideMenu write SetSideMenu;
  end;

Answer 1

使用 TRttiField.GetAttributes 会导致设计时错误。这是Delphi XE2 中的一个错误。请参阅QC Report .