Question

I am trying to write class that inherits from FMX TStyledControl. When style is updated it loads style resource objects to cache.

I created project group for package with custom controls and test FMX HD project as it describes in Delphi help. After installing package and placing TsgSlideHost on the test form I run test app. It works well, but when I close it and try to rebuild package RAD Studio says “Error in rtl160.bpl” or “invalid pointer operation”.

It seems what problem in LoadToCacheIfNeeded procedure from TsgStyledControl, but I’m not understand why. Is there any restriction on using RTTI with FMX styles or anything?

TsgStyledControl sources:

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.

Using of 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

Using TRttiField.GetAttributes leads to errors in design-time. It’s a bug in Delphi XE2. See QC Report.