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.