Перейти к содержанию
Fire Monkey от А до Я
  • 0

ScrollingText

beegl

Ответ от beegl,

Вопрос

beegl Apprentice

beegl

Опубликовано
Опубликовано (изменено)

Подскажите, чем заменить TGraphicControl в FMX?

 

На Андроид переделать ScrollingText хочу)

 

Спойлер 

unit ALScrollingText;

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.WebBrowser, FMX.ScrollBox, FMX.Memo, FMX.Objects;

type
  TTextLayout = (tlTop, tlCenter, tlBottom);
  TTextDirection = (tdLeftToRight, tdRightToLeft);

  TALScrollingText = class(TGraphicControl)
  private
    fText: String;
    Timer: TTimer;
    fSpeed: Integer;
    fBackgroundColor: TColor;
    BackBitmap: TBitmap;
    DrawnBitmap: TBitmap;
    WholeBitmap: TBitmap;
    Position: Integer;
    fEdgeFade: Boolean;
    fEdgeFadeWidth: Integer;
    fLayout: TTextLayout;
    fTextDirection: TTextDirection;
    fPixelJump: Integer;
    fVisible: Boolean;
    procedure SetText(const Value: String);
    procedure SetSpeed(const Value: Integer);
    procedure OnTimer(Sender: TObject);
    procedure SetBackgroundColor(const Value: TColor);
    procedure CMFontChanged(var Msg: TMessage); message CM_FontChanged;
    procedure InvalidateEverything;
    procedure SetEdgeFadeWidth(const Value: Integer);
    function CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
    procedure SetLayout(const Value: TTextLayout);
    procedure SetTextDirection(const Value: TTextDirection);
    procedure SetVisible(const Value: Boolean);
  protected
    procedure Paint; override;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Resize; override;
  published
    property Text: String                   read fText              write SetText;
    property Speed: Integer                 read fSpeed             write SetSpeed              default 50;
    property BackgroundColor: TColor        read fBackgroundColor   write SetBackgroundColor    default clBtnFace;
    property EdgeFadeWidth: Integer         read fEdgeFadeWidth     write SetEdgeFadeWidth      default 15;
    property Layout: TTextLayout            read fLayout            write SetLayout             default tlCenter;
    property TextDirection: TTextDirection  read fTextDirection     write SetTextDirection      default tdLeftToRight;
    property PixelJump: Integer             read fPixelJump         write fPixelJump            default 1;
    property Visible: Boolean               read fVisible           write SetVisible;
    property Font;
    property Enabled;
    property ParentFont;
    property OnMouseDown;
    property OnMouseUp;
    property OnClick;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('ScrollingTextEx', [TALScrollingText]);
end;

{ TALScrollingText }

constructor TALScrollingText.Create(AOwner: TComponent);
begin
  inherited;

  BackBitmap := TBitmap.Create;
  DrawnBitmap := TBitmap.Create;
  WholeBitmap := TBitmap.Create;
  WholeBitmap.Transparent := True;

  Timer := TTimer.Create(nil);
  Timer.OnTimer := OnTimer;

  Width := 50;
  Height := 18;

  ParentFont := True;

  fVisible := True;
  fText := 'Text';
  Speed := 50;
  fEdgeFade := True;
  fEdgeFadeWidth := 15;
  fBackgroundColor := clBtnFace;
  fLayout := tlCenter;
  fTextDirection := tdLeftToRight;
  fPixelJump := 1;
  Position := -Width;
  Font.Color := clWindowText;
end;

destructor TALScrollingText.Destroy;
begin
  Timer.Free;
  BackBitmap.Free;
  DrawnBitmap.Free;
  WholeBitmap.Free;

  inherited;
end;

procedure TALScrollingText.Loaded;
begin
  inherited;

  InvalidateEverything;
  if fTextDirection = tdLeftToRight then
    Position := -(WholeBitmap.Width - Width)
  else
    Position := 0;
end;

procedure TALScrollingText.OnTimer(Sender: TObject);
begin
  if Enabled then
  begin
    if fTextDirection = tdLeftToRight then
    begin
      Inc(Position, fPixelJump);
      if Position >= 0 then
        Position := -WholeBitmap.Width + Width;
    end
    else
    begin
      Dec(Position, fPixelJump);
      if Position <= -(WholeBitmap.Width - Width) then
        Position := 0;
    end;
    Paint;
  end;
end;

procedure TALScrollingText.Paint;
begin
  inherited;

  BitBlt(DrawnBitmap.Canvas.Handle, 0, 0, Width, Height, BackBitmap.Canvas.Handle, 0, 0, SrcCopy);
  DrawnBitmap.Canvas.Draw(Position, 0, WholeBitmap);

  BitBlt(Canvas.Handle, 0, 0, Width, Height, DrawnBitmap.Canvas.Handle, 0, 0, SrcCopy);
end;

procedure TALScrollingText.InvalidateEverything;
var
  i: Integer;
begin
  with WholeBitmap do
  begin
    Canvas.Brush.Color := fBackgroundColor;
    Canvas.FillRect(Rect(0, 0, Width, Height));
    Canvas.Font := Self.Font;
    Width := WholeBitmap.Canvas.TextWidth(fText) + (2 * Self.Width);
    Height := Self.Height;
    if (Self.Font.Color = clGreen) or (fBackgroundColor = clGreen) then
    begin
      TransparentColor := clRed;
      Canvas.Font.Color := clRed;
    end
    else
    begin
      TransparentColor := clGreen;
      Canvas.Font.Color := clGreen;
    end;
    if fLayout = tlTop then
      Canvas.TextOut(Self.Width, 0, fText)
    else if fLayout = tlCenter then
      Canvas.TextOut(Self.Width, (Self.Height div 2) - (Canvas.TextHeight(fText) div 2), fText)
    else
      Canvas.TextOut(Self.Width, Self.Height - Canvas.TextHeight(fText), fText);
  end;

  with BackBitmap do
  begin
    Width := Self.Width;
    Height := Self.Height;
    Canvas.Brush.Color := Self.Font.Color;
    Canvas.FillRect(Rect(0, 0, Self.Width, Self.Height));
    if fEdgeFadeWidth > 0 then
    begin
      for i := 0 to fEdgeFadeWidth-1 do
      begin
        Canvas.Pen.Color := CalcColorIndex(fBackgroundColor, Self.Font.Color, fEdgeFadeWidth, i+1);
        Canvas.MoveTo(i, 0);
        Canvas.LineTo(i, Self.Height);
        Canvas.MoveTo(Width-i-1, 0);
        Canvas.LineTo(Width-i-1, Self.Height);
      end;
    end;
  end;

  DrawnBitmap.Width := Width;
  DrawnBitmap.Height := Height;
end;

procedure TALScrollingText.CMFontChanged(var Msg: TMessage);
begin
  inherited;

  InvalidateEverything;
  Msg.Result := 1;
end;

procedure TALScrollingText.Resize;
begin
  inherited;

  InvalidateEverything;
end;

procedure TALScrollingText.SetBackgroundColor(const Value: TColor);
begin
  if fBackgroundColor <> Value then
  begin
    fBackgroundColor := Value;
    InvalidateEverything;
  end;
end;

procedure TALScrollingText.SetSpeed(const Value: Integer);
begin
  if fSpeed <> Value then
  begin
    fSpeed := Value;
    Timer.Interval := Value;
  end;
end;

procedure TALScrollingText.SetText(const Value: String);
begin
  if fText <> Value then
  begin
    fText := Value;
    InvalidateEverything;
  end;
end;

procedure TALScrollingText.SetEdgeFadeWidth(const Value: Integer);
begin
  if fEdgeFadeWidth <> Value then
  begin
    fEdgeFadeWidth := Value;
    InvalidateEverything;
  end;
end;

procedure TALScrollingText.SetLayout(const Value: TTextLayout);
begin
  if fLayout <> Value then
  begin
    fLayout := Value;
    InvalidateEverything;
  end;
end;

procedure TALScrollingText.SetTextDirection(const Value: TTextDirection);
begin
  if fTextDirection <> Value then
  begin
    fTextDirection := Value;
    if Value = tdLeftToRight then
      Position := -(WholeBitmap.Width - Width)
    else
      Position := 0;
    InvalidateEverything;
  end;
end;

function TALScrollingText.CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
var
  BeginRGBValue: Array[0..2] of Byte;
  RGBDifference: Array[0..2] of Integer;
  Red, Green, Blue: Byte;
  NumColors: Integer;
begin
  if (ColorIndex < 1) or (ColorIndex > Steps) then
    raise ERangeError.Create('ColorIndex can''t be less than 1 or greater than ' + IntToStr(Steps));
  NumColors := Steps;
  Dec(ColorIndex);
  BeginRGBValue[0] := GetRValue(ColorToRGB(StartColor));
  BeginRGBValue[1] := GetGValue(ColorToRGB(StartColor));
  BeginRGBValue[2] := GetBValue(ColorToRGB(StartColor));
  RGBDifference[0] := GetRValue(ColorToRGB(EndColor)) - BeginRGBValue[0];
  RGBDifference[1] := GetGValue(ColorToRGB(EndColor)) - BeginRGBValue[1];
  RGBDifference[2] := GetBValue(ColorToRGB(EndColor)) - BeginRGBValue[2];

  // Calculate the bands color
  Red := BeginRGBValue[0] + MulDiv(ColorIndex, RGBDifference[0], NumColors - 1);
  Green := BeginRGBValue[1] + MulDiv(ColorIndex, RGBDifference[1], NumColors - 1);
  Blue := BeginRGBValue[2] + MulDiv(ColorIndex, RGBDifference[2], NumColors - 1);
  Result := RGB(Red, Green, Blue);
end;

procedure TALScrollingText.SetVisible(const Value: Boolean);
begin
  if Value <> fVisible then
  begin
    fVisible := Value;
    Enabled := fVisible;
    TGraphicControl(Self).Visible := fVisible;
  end;
end;

end.

 

 

ddddddddd.gif

Изменено пользователем beegl
Ссылка на комментарий

2 ответа на этот вопрос

Рекомендуемые сообщения

  • 0
Error Collaborator

Error

Опубликовано
Опубликовано
10 часов назад, beegl сказал:

Подскажите, чем заменить TGraphicControl в FMX?

 

На Андроид переделать ScrollingText хочу)

 

  Скрыть контент 


unit ALScrollingText;

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.WebBrowser, FMX.ScrollBox, FMX.Memo, FMX.Objects;

type
  TTextLayout = (tlTop, tlCenter, tlBottom);
  TTextDirection = (tdLeftToRight, tdRightToLeft);

  TALScrollingText = class(TGraphicControl)
  private
    fText: String;
    Timer: TTimer;
    fSpeed: Integer;
    fBackgroundColor: TColor;
    BackBitmap: TBitmap;
    DrawnBitmap: TBitmap;
    WholeBitmap: TBitmap;
    Position: Integer;
    fEdgeFade: Boolean;
    fEdgeFadeWidth: Integer;
    fLayout: TTextLayout;
    fTextDirection: TTextDirection;
    fPixelJump: Integer;
    fVisible: Boolean;
    procedure SetText(const Value: String);
    procedure SetSpeed(const Value: Integer);
    procedure OnTimer(Sender: TObject);
    procedure SetBackgroundColor(const Value: TColor);
    procedure CMFontChanged(var Msg: TMessage); message CM_FontChanged;
    procedure InvalidateEverything;
    procedure SetEdgeFadeWidth(const Value: Integer);
    function CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
    procedure SetLayout(const Value: TTextLayout);
    procedure SetTextDirection(const Value: TTextDirection);
    procedure SetVisible(const Value: Boolean);
  protected
    procedure Paint; override;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Resize; override;
  published
    property Text: String                   read fText              write SetText;
    property Speed: Integer                 read fSpeed             write SetSpeed              default 50;
    property BackgroundColor: TColor        read fBackgroundColor   write SetBackgroundColor    default clBtnFace;
    property EdgeFadeWidth: Integer         read fEdgeFadeWidth     write SetEdgeFadeWidth      default 15;
    property Layout: TTextLayout            read fLayout            write SetLayout             default tlCenter;
    property TextDirection: TTextDirection  read fTextDirection     write SetTextDirection      default tdLeftToRight;
    property PixelJump: Integer             read fPixelJump         write fPixelJump            default 1;
    property Visible: Boolean               read fVisible           write SetVisible;
    property Font;
    property Enabled;
    property ParentFont;
    property OnMouseDown;
    property OnMouseUp;
    property OnClick;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('ScrollingTextEx', [TALScrollingText]);
end;

{ TALScrollingText }

constructor TALScrollingText.Create(AOwner: TComponent);
begin
  inherited;

  BackBitmap := TBitmap.Create;
  DrawnBitmap := TBitmap.Create;
  WholeBitmap := TBitmap.Create;
  WholeBitmap.Transparent := True;

  Timer := TTimer.Create(nil);
  Timer.OnTimer := OnTimer;

  Width := 50;
  Height := 18;

  ParentFont := True;

  fVisible := True;
  fText := 'Text';
  Speed := 50;
  fEdgeFade := True;
  fEdgeFadeWidth := 15;
  fBackgroundColor := clBtnFace;
  fLayout := tlCenter;
  fTextDirection := tdLeftToRight;
  fPixelJump := 1;
  Position := -Width;
  Font.Color := clWindowText;
end;

destructor TALScrollingText.Destroy;
begin
  Timer.Free;
  BackBitmap.Free;
  DrawnBitmap.Free;
  WholeBitmap.Free;

  inherited;
end;

procedure TALScrollingText.Loaded;
begin
  inherited;

  InvalidateEverything;
  if fTextDirection = tdLeftToRight then
    Position := -(WholeBitmap.Width - Width)
  else
    Position := 0;
end;

procedure TALScrollingText.OnTimer(Sender: TObject);
begin
  if Enabled then
  begin
    if fTextDirection = tdLeftToRight then
    begin
      Inc(Position, fPixelJump);
      if Position >= 0 then
        Position := -WholeBitmap.Width + Width;
    end
    else
    begin
      Dec(Position, fPixelJump);
      if Position <= -(WholeBitmap.Width - Width) then
        Position := 0;
    end;
    Paint;
  end;
end;

procedure TALScrollingText.Paint;
begin
  inherited;

  BitBlt(DrawnBitmap.Canvas.Handle, 0, 0, Width, Height, BackBitmap.Canvas.Handle, 0, 0, SrcCopy);
  DrawnBitmap.Canvas.Draw(Position, 0, WholeBitmap);

  BitBlt(Canvas.Handle, 0, 0, Width, Height, DrawnBitmap.Canvas.Handle, 0, 0, SrcCopy);
end;

procedure TALScrollingText.InvalidateEverything;
var
  i: Integer;
begin
  with WholeBitmap do
  begin
    Canvas.Brush.Color := fBackgroundColor;
    Canvas.FillRect(Rect(0, 0, Width, Height));
    Canvas.Font := Self.Font;
    Width := WholeBitmap.Canvas.TextWidth(fText) + (2 * Self.Width);
    Height := Self.Height;
    if (Self.Font.Color = clGreen) or (fBackgroundColor = clGreen) then
    begin
      TransparentColor := clRed;
      Canvas.Font.Color := clRed;
    end
    else
    begin
      TransparentColor := clGreen;
      Canvas.Font.Color := clGreen;
    end;
    if fLayout = tlTop then
      Canvas.TextOut(Self.Width, 0, fText)
    else if fLayout = tlCenter then
      Canvas.TextOut(Self.Width, (Self.Height div 2) - (Canvas.TextHeight(fText) div 2), fText)
    else
      Canvas.TextOut(Self.Width, Self.Height - Canvas.TextHeight(fText), fText);
  end;

  with BackBitmap do
  begin
    Width := Self.Width;
    Height := Self.Height;
    Canvas.Brush.Color := Self.Font.Color;
    Canvas.FillRect(Rect(0, 0, Self.Width, Self.Height));
    if fEdgeFadeWidth > 0 then
    begin
      for i := 0 to fEdgeFadeWidth-1 do
      begin
        Canvas.Pen.Color := CalcColorIndex(fBackgroundColor, Self.Font.Color, fEdgeFadeWidth, i+1);
        Canvas.MoveTo(i, 0);
        Canvas.LineTo(i, Self.Height);
        Canvas.MoveTo(Width-i-1, 0);
        Canvas.LineTo(Width-i-1, Self.Height);
      end;
    end;
  end;

  DrawnBitmap.Width := Width;
  DrawnBitmap.Height := Height;
end;

procedure TALScrollingText.CMFontChanged(var Msg: TMessage);
begin
  inherited;

  InvalidateEverything;
  Msg.Result := 1;
end;

procedure TALScrollingText.Resize;
begin
  inherited;

  InvalidateEverything;
end;

procedure TALScrollingText.SetBackgroundColor(const Value: TColor);
begin
  if fBackgroundColor <> Value then
  begin
    fBackgroundColor := Value;
    InvalidateEverything;
  end;
end;

procedure TALScrollingText.SetSpeed(const Value: Integer);
begin
  if fSpeed <> Value then
  begin
    fSpeed := Value;
    Timer.Interval := Value;
  end;
end;

procedure TALScrollingText.SetText(const Value: String);
begin
  if fText <> Value then
  begin
    fText := Value;
    InvalidateEverything;
  end;
end;

procedure TALScrollingText.SetEdgeFadeWidth(const Value: Integer);
begin
  if fEdgeFadeWidth <> Value then
  begin
    fEdgeFadeWidth := Value;
    InvalidateEverything;
  end;
end;

procedure TALScrollingText.SetLayout(const Value: TTextLayout);
begin
  if fLayout <> Value then
  begin
    fLayout := Value;
    InvalidateEverything;
  end;
end;

procedure TALScrollingText.SetTextDirection(const Value: TTextDirection);
begin
  if fTextDirection <> Value then
  begin
    fTextDirection := Value;
    if Value = tdLeftToRight then
      Position := -(WholeBitmap.Width - Width)
    else
      Position := 0;
    InvalidateEverything;
  end;
end;

function TALScrollingText.CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
var
  BeginRGBValue: Array[0..2] of Byte;
  RGBDifference: Array[0..2] of Integer;
  Red, Green, Blue: Byte;
  NumColors: Integer;
begin
  if (ColorIndex < 1) or (ColorIndex > Steps) then
    raise ERangeError.Create('ColorIndex can''t be less than 1 or greater than ' + IntToStr(Steps));
  NumColors := Steps;
  Dec(ColorIndex);
  BeginRGBValue[0] := GetRValue(ColorToRGB(StartColor));
  BeginRGBValue[1] := GetGValue(ColorToRGB(StartColor));
  BeginRGBValue[2] := GetBValue(ColorToRGB(StartColor));
  RGBDifference[0] := GetRValue(ColorToRGB(EndColor)) - BeginRGBValue[0];
  RGBDifference[1] := GetGValue(ColorToRGB(EndColor)) - BeginRGBValue[1];
  RGBDifference[2] := GetBValue(ColorToRGB(EndColor)) - BeginRGBValue[2];

  // Calculate the bands color
  Red := BeginRGBValue[0] + MulDiv(ColorIndex, RGBDifference[0], NumColors - 1);
  Green := BeginRGBValue[1] + MulDiv(ColorIndex, RGBDifference[1], NumColors - 1);
  Blue := BeginRGBValue[2] + MulDiv(ColorIndex, RGBDifference[2], NumColors - 1);
  Result := RGB(Red, Green, Blue);
end;

procedure TALScrollingText.SetVisible(const Value: Boolean);
begin
  if Value <> fVisible then
  begin
    fVisible := Value;
    Enabled := fVisible;
    TGraphicControl(Self).Visible := fVisible;
  end;
end;

end.

 

 

ddddddddd.gif

не очень понятно какое это имеет отношение к теме поста.

А унаследоваться от TControl можно. 

Ссылка на комментарий

Присоединяйтесь к обсуждению

Вы можете написать сейчас и зарегистрироваться позже. Если у вас есть аккаунт, авторизуйтесь, чтобы опубликовать от имени своего аккаунта.

Гость
Ответить на вопрос...

×   Вставлено с форматированием.   Вставить как обычный текст

  Разрешено использовать не более 75 эмодзи.

×   Ваша ссылка была автоматически встроена.   Отображать как обычную ссылку

×   Ваш предыдущий контент был восстановлен.   Очистить редактор

×   Вы не можете вставлять изображения напрямую. Загружайте или вставляйте изображения по ссылке.

×
Перейти к списку вопросов

  • Последние посетители   0 пользователей онлайн

    • Ни одного зарегистрированного пользователя не просматривает данную страницу
×
×
  • Создать...