使用RTTI加载FireMonkey风格资源

Question

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

我创建了项目组，包含自定义控件并测试了在Delphi帮助中描述的FMX HD项目。在安装包并将TsgSlideHost放置在测试表单上后，我运行测试应用程序。它工作的很好，但是当我关闭它并尝试重建RAD Studio时，会出现“Error in rtl160.bpl”或“无效指针操作”。

从TsgStyledControl的LoadToCacheIfNeeded过程似乎是什么问题，但我不明白为什么。使用FMTI风格或其他任何方式的RTTI有没有限制？

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。