Performanceproblem mit Firemonkey

[TiGü]

Probiere es doch mal so:

Delphi-Quellcode:

unit Unit3;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes,
  System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
  FMX.Controls.Presentation, FMX.StdCtrls, FMX.Objects, FMX.TextLayout;

type
  TForm3 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen }
    FScreenScale: single;
    FTitle: String;
    FDescription: String;
    FTitleTextLayout: TTextLayout;
    FDescTextLayout: TTextLayout;
    procedure DefaultRenderItem(const ACanvas: TCanvas; const ARect: TRectF; const AImage: TBitmap; const ASelected: Boolean);
  public
    { Public-Deklarationen }
  end;

  TCanvasHelper = class helper for TCanvas
  public
    procedure PetersFillText(const ATextLayout: TTextLayout; const ARect: TRectF; const AText: string; const WordWrap: Boolean;
      const AOpacity: single; const Flags: TFillTextFlags; const ATextAlign, AVTextAlign: TTextAlign);
  end;

var
  Form3: TForm3;

implementation

{$R *.fmx}

const
  cCardBackgroundColor = $FF3D3D3D;
  cCardDescription = $FF0096A6;
  cCardDescriptionFocus = $FF37474F;
  cGridFont = 'Roboto';

procedure TForm3.Button1Click(Sender: TObject);
var
  tick: Cardinal;
  i: Integer;
  Target: TBitmap;
  Image: TBitmap;
begin
  FTitle := 'Tile 1';
  FDescription := 'Panel 1, lorem ipsum';
  tick := TThread.GetTickCount;
  FScreenScale := 1;
  for i := 1 to 1000 do
  begin
    Image := TBitmap.Create;
    try
      // Image.Assign(Image1.Bitmap);

      Target := TBitmap.Create(180, 144);
      DefaultRenderItem(Target.Canvas, Target.BoundsF, Image, false);
      Target.Free;

      Target := TBitmap.Create(180, 144);
      DefaultRenderItem(Target.Canvas, Target.BoundsF, Image, true);

      if i = 1000 then // zu Debugzwecken
        Image2.Bitmap.Assign(Target);

      Target.Free;

    finally
      Image.Free;
    end;
  end;
  Label1.Text := IntToStr(TThread.GetTickCount - tick);
end;

procedure TForm3.DefaultRenderItem(const ACanvas: TCanvas; const ARect: TRectF; const AImage: TBitmap; const ASelected: Boolean);
var
  i: Integer;
  TH: single;
  ABoundsRect: TRectF;
  R: TRectF;
  TextLayout: TTextLayout;
begin
  ABoundsRect := ARect;
  with ACanvas do
  begin
    BeginScene(nil);
    try
      // Shadow - there are much nicer ways to draw a shadow
      ClearRect(ARect);

      Stroke.Kind := TBrushkind.Solid;
      Stroke.Color := TAlphaColorRec.Black;
      for i := 0 to 5 do
      begin
        DrawRect(ABoundsRect, 5, 5, AllCorners, i / 100);;
        ABoundsRect := RectF(ABoundsRect.Left + 1, ABoundsRect.Top + 1, ABoundsRect.Right - 1, ABoundsRect.Bottom - 1);
      end;
      Stroke.Kind := TBrushkind.None;
      Fill.Kind := TBrushkind.Solid;
      Fill.Color := cCardBackgroundColor;
      FillRect(ABoundsRect, 0 * 5, 0 * 5, AllCorners, 1);

      TH := ABoundsRect.Height / 3;
      if Assigned(AImage) then
      begin
        R := RectF(ABoundsRect.Left, 0, ABoundsRect.Right, ABoundsRect.Bottom - TH);

        Fill.Bitmap.Bitmap.Assign(AImage);
        Fill.Bitmap.WrapMode := TWrapMode.TileStretch;
        Fill.Kind := TBrushkind.Bitmap;
        FillRect(R, 5, 5, [TCorner.TopLeft, TCorner.TopRight], 1);
      end;

      R := RectF(ABoundsRect.Left, ABoundsRect.Bottom - TH, ABoundsRect.Right, ABoundsRect.Bottom);

      Fill.Kind := TBrushkind.Solid;
      if ASelected then
        Fill.Color := cCardDescription
      else
        Fill.Color := cCardDescriptionFocus;

      FillRect(R, 5, 5, [TCorner.BottomLeft, TCorner.BottomRight], 1);

      R := RectF(R.Left + 10, R.Top, R.Right - 10, R.Top + (R.Bottom - R.Top) / 2);

      Fill.Color := TAlphaColorRec.White;

      if FTitle <> '' then
      begin
        if FTitleTextLayout = nil then
        begin
          Font.Family := cGridFont;
          Font.Size := FScreenScale * 15;
          Font.Style := [TFontStyle.fsBold];

          FTitleTextLayout := TTextLayoutManager.TextLayoutByCanvas(ACanvas.ClassType).Create(ACanvas);
          PetersFillText(FTitleTextLayout, R, FTitle, false, 1, [], TTextAlign.Leading, TTextAlign.Center);
        end;
        FTitleTextLayout.RenderLayout(ACanvas);
      end;

      if FDescription <> '' then
      begin
        if FDescTextLayout = nil then
        begin
          R.Offset(0, R.Height);
          Font.Style := [];

          FDescTextLayout := TTextLayoutManager.TextLayoutByCanvas(ACanvas.ClassType).Create(ACanvas);
          PetersFillText(FDescTextLayout, R, FDescription, false, 0.8, [], TTextAlign.Leading, TTextAlign.Leading);
        end;
        FDescTextLayout.RenderLayout(ACanvas);
      end;
    finally
      EndScene;
    end;
  end;
end;

{ TCanvasHelper }

procedure TCanvasHelper.PetersFillText(const ATextLayout: TTextLayout; const ARect: TRectF; const AText: string;
  const WordWrap: Boolean; const AOpacity: single; const Flags: TFillTextFlags; const ATextAlign, AVTextAlign: TTextAlign);

begin
  ATextLayout.BeginUpdate;
  ATextLayout.TopLeft := ARect.TopLeft;
  ATextLayout.MaxSize := PointF(ARect.Width, ARect.Height);
  ATextLayout.Text := AText;
  ATextLayout.WordWrap := WordWrap;
  ATextLayout.Opacity := AOpacity;
  ATextLayout.HorizontalAlign := ATextAlign;
  ATextLayout.VerticalAlign := AVTextAlign;
  ATextLayout.Font := Self.Font;
  ATextLayout.Color := Self.Fill.Color;
  ATextLayout.RightToLeft := TFillTextFlag.RightToLeft in Flags;
  ATextLayout.EndUpdate;
end;

end.