Firemonkey Marquee ScrollLabel

[Peter666]

Vielleicht kennt ihr das ja auch: Der Text ist zu lang für ein TLabel und mit Bordmitteln funktioniert kein Scrollen wie man das zum Beispiel von iTunes kennt.

Delphi-Quellcode:

unit UScrollLabel;

interface

uses System.SysUtils, System.Classes, System.Types, System.UITypes,
  FMX.Graphics, FMX.Types, FMX.Controls;

type
  TScrollLabel = class(TControl)
  private
    FXOffset: single;
    FPausedTicks: Integer;
    FMaxPause: Integer;
    FTextSize: TSizeF;
    FStepSize: single;
    FFontColor: TAlphaColor;

    FText: String;
    FFont: TFont;
    FZoomFactor: Integer;
    FBackBuffer: TBitmap;
  protected
    procedure Paint; override;
    procedure SetText(const Value: String);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Text: String read FText write SetText;
    property Font: TFont read FFont;
    property FontColor: TAlphaColor read FFontColor write FFontColor;
    property MaxPause: Integer read FMaxPause write FMaxPause;

    property Align;
    property Anchors;
    property ClipChildren default false;
    property ClipParent default false;
    property DesignVisible default True;
    property Enabled default True;
    property Locked default false;
    property Height;
    property HitTest default True;
    property Padding;
    property Opacity;
    property Margins;
    property PopupMenu;
    property position;
    property RotationAngle;
    property RotationCenter;
    property Scale;
    property Visible default True;
    property Width;

    { Mouse events }
    property OnClick;
    property OnDblClick;

    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseEnter;
    property OnMouseLeave;

    property OnPainting;
    property OnPaint;
    property OnResize;
  end;

implementation

uses System.Math;

constructor TScrollLabel.Create(AOwner: TComponent);
begin
  inherited;
  FFont := TFont.Create;
  FFontColor := $FFFFFFFF;
  FZoomFactor := 4;
  FMaxPause := 100;
end;

destructor TScrollLabel.Destroy;
begin
  FreeAndNil(FBackBuffer);
  FreeAndNil(FFont);
  inherited;
end;

procedure TScrollLabel.SetText(const Value: String);
begin
  FreeAndNil(FBackBuffer);
  FText := Value;
end;

procedure TScrollLabel.Paint;
var
  src, dst: TRectF;
  cy, cx: single;
  R: TRectF;
begin
  if (FText = '') or (FZoomFactor = 0) then
    exit;

  if not assigned(FBackBuffer) then
  begin
    FPausedTicks := FMaxPause;
    FStepSize := 4;

    R := RectF(0, 0, 10000, 10000);

    Canvas.Font.Assign(FFont);
    Canvas.Font.Size := FFont.Size * FZoomFactor;

    Canvas.MeasureText(R, FText, false, [], TTextAlign.taLeading,
      TTextAlign.taLeading);
    FTextSize := R.Size;

    FBackBuffer := TBitmap.Create(FTextSize.Round.Width,
      FTextSize.Round.Height);
    FBackBuffer.Canvas.BeginScene(nil);
    try
      FBackBuffer.Canvas.Font.Assign(Canvas.Font);
      FBackBuffer.Canvas.Clear(0);
      FBackBuffer.Canvas.Fill.Color := FFontColor;
      FBackBuffer.Canvas.Fill.Kind := TBrushKind.bkSolid;
      FBackBuffer.Canvas.FillText(RectF(0, 0, FTextSize.Width,
        FTextSize.Height), FText, false, 1, [], TTextAlign.taLeading,
        TTextAlign.taLeading);
    finally
      FBackBuffer.Canvas.EndScene;
    end;
  end;

  src := RectF(-FXOffset, 0, min(FBackBuffer.Width, FZoomFactor * Width) -
    FXOffset, FBackBuffer.Height);
  cy := (Height - FBackBuffer.Height / FZoomFactor) / 2;

  if FTextSize.Width > FZoomFactor * Width then
  begin
    if FPausedTicks > 0 then
      dec(FPausedTicks)
    else
    begin
      if (FXOffset > 0) or (FXOffset + FTextSize.Width < FZoomFactor * Width)
      then
      begin
        FStepSize := -FStepSize;
        if (FXOffset > 0) then
          FPausedTicks := FMaxPause;
      end;
      FXOffset := FXOffset - FStepSize;
    end;
    dst := RectF(0, cy, Width, cy + FBackBuffer.Height / FZoomFactor)
  end
  else
  begin
    cx := (Width - FBackBuffer.Width / FZoomFactor) / 2;
    dst := RectF(cx, cy, cx + FBackBuffer.Width / FZoomFactor,
      cy + FBackBuffer.Height / FZoomFactor);
  end;

  Canvas.DrawBitmap(FBackBuffer, src, dst, 1);
end;

end.

Der beiliegende Code funktioniert recht gut, leider musste ich den Backbuffer 4x so groß machen wie die eigentliche Anzeige, da sonst der Font verwaschen ist. Auf Android will er auch nicht, aber eventuell sieht ja jemand das Problem.

[Union]

Ja, Du hast das Canvas.BeginScene und EndScene vergessen beim Übertragen des Backbuffer.

[Peter666]

Bei einer Komponente ist das nicht notwendig, der zeichnet das komplette Display neu und da ist schon mind. ein BeginScene am Anfang. Trotzdem danke für die schnelle Antwort.
Das Problem ist das bei Android die Backbufferbitmap nicht gezeichnet wird.

[Peter666]

Hmm scheinbar ist der Text zu lang und somit die Backbuffer-Bitmap zu groß.

[Union]

Ja, Bitmaps werden von FMX als GL-Texturen verwaltet und dann hängt es von der Textur-Puffergröße ab ob es geht oder nicht:

Delphi-Quellcode:

{$ifndef ANDROID}
  glGetIntegerv(GL_MAX_TEXTURE_SIZE, @MaxTextureSize);
{$else}
  MaxTextureSize := 4096;
{$endif}

MaxScale := MaxTextureSize/(Painter.Bitmap.Width/Painter.Scale);

[Peter666]

Delphi-Quellcode:

unit UScrollLabel;

interface

uses System.SysUtils, System.Classes, System.Types, System.UITypes,
  FMX.Graphics, FMX.Types, FMX.Controls;

type
  TScrollLabel = class(TControl)
  private
    FXOffset: single;
    FPausedTicks: Integer;
    FMaxPause: Integer;
    FStepSize: single;
    FFontColor: TAlphaColor;
    FTextSize: TSizeF;

    FText: String;
    FFont: TFont;
  protected
    procedure Paint; override;
    procedure SetText(const Value: String);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Text: String read FText write SetText;
    property Font: TFont read FFont;
    property FontColor: TAlphaColor read FFontColor write FFontColor;
    property MaxPause: Integer read FMaxPause write FMaxPause;

    property Align;
    property Anchors;
    property ClipChildren default false;
    property ClipParent default false;
    property DesignVisible default True;
    property Enabled default True;
    property Locked default false;
    property Height;
    property HitTest default True;
    property Padding;
    property Opacity;
    property Margins;
    property PopupMenu;
    property position;
    property RotationAngle;
    property RotationCenter;
    property Scale;
    property Visible default True;
    property Width;

    { Mouse events }
    property OnClick;
    property OnDblClick;

    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseEnter;
    property OnMouseLeave;

    property OnPainting;
    property OnPaint;
    property OnResize;
  end;

implementation

uses System.Math, FMX.TextLayout;

constructor TScrollLabel.Create(AOwner: TComponent);
begin
  inherited;
  FFont := TFont.Create;
  FFontColor := $FFFFFFFF;
  FMaxPause := 100;
  FStepSize := 4;
end;

destructor TScrollLabel.Destroy;
begin
  FreeAndNil(FFont);
  inherited;
end;

procedure TScrollLabel.SetText(const Value: String);
begin
  FText := Value;
  Fillchar(FTextSize,sizeof(FTextSize),0);
end;

procedure TScrollLabel.Paint;
var
  Layout: TTextLayout;
  R: TRectF;
begin
  if FTextSize.IsZero then
  begin
    Canvas.Font.Assign(Font);
    R := RectF(0, 0, 10000, 10000);
    Canvas.MeasureText(R, Text, false, [], TTextAlign.taLeading,
      TTextAlign.taLeading);
    FTextSize := R.Size;
    FPausedTicks := FMaxPause;
  end;

  if FTextSize.Width > Width then
  begin
    if FPausedTicks > 0 then
      dec(FPausedTicks)
    else
    begin
      if (FXOffset > 0) or (FXOffset + FTextSize.Width < Width) then
      begin
        FStepSize := -FStepSize;
        if (FXOffset > 0) then
          FPausedTicks := FMaxPause;
      end;
      FXOffset := FXOffset - FStepSize;
    end;
  end;

  Layout := TTextLayoutManager.TextLayoutByCanvas(Canvas.ClassType)
    .Create(Canvas);
  try
    Layout.BeginUpdate;
    Layout.TopLeft := PointF(FXOffset + 8, 0);
    Layout.MaxSize := PointF(Width - FXOffset - 8, Height);
    Layout.Text := FText;
    Layout.WordWrap := false;
    Layout.Opacity := 1;
    Layout.HorizontalAlign := TTextAlign.taLeading;
    Layout.VerticalAlign := TTextAlign.taCenter;
    Layout.Font := Font;
    Layout.Color := FFontColor;
    Layout.RightToLeft := false; // TFillTextFlag.ftRightToLeft in Flags;
    Layout.EndUpdate;
    Layout.RenderLayout(Canvas);
  finally
    FreeAndNil(Layout);
  end;
end;

end.

Ich hab das jetzt mal abgeändert, aber nur unter Windows macht er das Clipping richtig. Android und IOS zeichnet den Text außerhalb des Bereiches. Kann ich das irgendwie umgehen?

[Union]

Zitat von Peter666:

Ich hab das jetzt mal abgeändert, aber nur unter Windows macht er das Clipping richtig. Android und IOS zeichnet den Text außerhalb des Bereiches. Kann ich das irgendwie umgehen?

Die Bitmap hat je nach Gerät und auf dem Simulator teilweise intern eine andere Skalierung. Die kannst Du Dir über den IFMXScreenService.GetScreeenScale holen.

[Peter666]

Danke, ich hatte mich nur noch mal belesen im FMX Code und probiert ohne einen Backbuffer auszukommen. Mit der TTextLayout Klasse kann ich das ja auch so rendern, allerdings zeichnet er über den angegebenen Anfangspunkt (Position.X) hinaus und überschreibt das schon gezeichnete mit obigen Code. Den Paddingwert ignoriert er außerhalb von Windows und irgendwie hab ich das Gefühl das ganze ist nur eine Kleinigkeit. Ich frage mich ob das so in der Form noch nie jemand gebraucht hat

[Union]

Ich habe auch das Gefühl dass die Mobile Entwicklung hier nicht so der Renner ist. Sind nur eine Hand voll Leute die das machen.