使用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。