Загрузка ресурсов в стиле FireMonkey с помощью RTTI

Я пытаюсь написать класс, который наследуется от FMX TStyledControl. Когда стиль обновляется, он загружает объекты ресурса стиля в кеш.

Я создал проектную группу для пакета с пользовательскими элементами управления и протестировал проект FMX HD, как это описано в справке Delphi. После установки пакета и размещения TsgSlideHost в тестовой форме я запускаю тестовое приложение. Он работает хорошо, но когда я его закрываю и пытаюсь пересобрать пакет, RAD Studio пишет "Ошибка в rtl160.bpl" или "недопустимая операция указателя".

Вроде какая проблема в процедуре LoadToCacheIfNeeded из TsgStyledControl, но не пойму почему. Есть ли какие-либо ограничения на использование 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;
6
задан hubalazs 13 June 2012 в 13:38
поделиться