Question

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

我使用自定义控件和测试FMX HD项目创建了包的项目组，如Delphi帮助中所述。安装包并将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。

使用RTTI加载FireMonkey样式资源

1 个答案: