AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren

Firemonkey Marquee ScrollLabel

Ein Thema von Peter666 · begonnen am 17. Mär 2014 · letzter Beitrag vom 17. Mär 2014
Antwort Antwort
Peter666

Registriert seit: 11. Aug 2007
357 Beiträge
 
#1

Firemonkey Marquee ScrollLabel

  Alt 17. Mär 2014, 14:49
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.
  Mit Zitat antworten Zitat
Benutzerbild von Union
Union

Registriert seit: 18. Mär 2004
Ort: Luxembourg
3.487 Beiträge
 
Delphi 7 Enterprise
 
#2

AW: Firemonkey Marquee ScrollLabel

  Alt 17. Mär 2014, 14:52
Ja, Du hast das Canvas.BeginScene und EndScene vergessen beim Übertragen des Backbuffer.
Ibi fas ubi proxima merces
sudo /Developer/Library/uninstall-devtools --mode=all
  Mit Zitat antworten Zitat
Peter666

Registriert seit: 11. Aug 2007
357 Beiträge
 
#3

AW: Firemonkey Marquee ScrollLabel

  Alt 17. Mär 2014, 14:55
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.
  Mit Zitat antworten Zitat
Peter666

Registriert seit: 11. Aug 2007
357 Beiträge
 
#4

AW: Firemonkey Marquee ScrollLabel

  Alt 17. Mär 2014, 15:11
Hmm scheinbar ist der Text zu lang und somit die Backbuffer-Bitmap zu groß.
  Mit Zitat antworten Zitat
Benutzerbild von Union
Union

Registriert seit: 18. Mär 2004
Ort: Luxembourg
3.487 Beiträge
 
Delphi 7 Enterprise
 
#5

AW: Firemonkey Marquee ScrollLabel

  Alt 17. Mär 2014, 15:21
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);
Ibi fas ubi proxima merces
sudo /Developer/Library/uninstall-devtools --mode=all
  Mit Zitat antworten Zitat
Peter666

Registriert seit: 11. Aug 2007
357 Beiträge
 
#6

AW: Firemonkey Marquee ScrollLabel

  Alt 17. Mär 2014, 18:31
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?
  Mit Zitat antworten Zitat
Benutzerbild von Union
Union

Registriert seit: 18. Mär 2004
Ort: Luxembourg
3.487 Beiträge
 
Delphi 7 Enterprise
 
#7

AW: Firemonkey Marquee ScrollLabel

  Alt 17. Mär 2014, 18:52
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.
Ibi fas ubi proxima merces
sudo /Developer/Library/uninstall-devtools --mode=all
  Mit Zitat antworten Zitat
Peter666

Registriert seit: 11. Aug 2007
357 Beiträge
 
#8

AW: Firemonkey Marquee ScrollLabel

  Alt 17. Mär 2014, 19:41
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
  Mit Zitat antworten Zitat
Benutzerbild von Union
Union

Registriert seit: 18. Mär 2004
Ort: Luxembourg
3.487 Beiträge
 
Delphi 7 Enterprise
 
#9

AW: Firemonkey Marquee ScrollLabel

  Alt 17. Mär 2014, 21:06
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.
Ibi fas ubi proxima merces
sudo /Developer/Library/uninstall-devtools --mode=all
  Mit Zitat antworten Zitat
Themen-Optionen Thema durchsuchen
Thema durchsuchen:

Erweiterte Suche
Ansicht

Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 07:12 Uhr.
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024 by Thomas Breitkreuz