Delphi: Scrolling text label component

Here’s a component I made a long time ago. This is a label that scroll’s the text.

You can set the scroll speed with the property: ScrollSpeed
You can specify if the text should scroll once or repeat in a loop with the property: RepeatScroll
And you have two events that tell you when the scrolling starts and stops: OnStartScroll, OnEndScroll

unit caScrollLabel;

interface

uses
  StdCtrls, Messages, Windows, ExtCtrls, Controls, Classes;

type
  TcaScrollLabel = class(TLabel)
  private
    FScrollTimer: TTimer;
    FScrollPos: Integer;
    FTextWidth: Integer;
    FOnEndScroll: TNotifyEvent;
    FOnStartScroll: TNotifyEvent;
    FScrolling: Boolean;
    FRepeatScroll: Boolean;
    FScrollSpeed: Cardinal;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure ScrollTimer(Sender: TObject);
    procedure SetOnEndScroll(const Value: TNotifyEvent);
    procedure SetOnStartScroll(const Value: TNotifyEvent);
    procedure SetRepeatScroll(const Value: Boolean);
    procedure SetScrollSpeed(const Value: Cardinal);
  protected
    procedure Paint; override;
    procedure SetAutoSize(Value: Boolean); override;
    procedure DoStartScroll;
    procedure DoEndScroll;
    procedure StartScrolling();
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Scrolling: Boolean read FScrolling;
  published
    property OnStartScroll: TNotifyEvent read FOnStartScroll write SetOnStartScroll;
    property OnEndScroll: TNotifyEvent read FOnEndScroll write SetOnEndScroll;
    property RepeatScroll: Boolean read FRepeatScroll write SetRepeatScroll;
    property ScrollSpeed: Cardinal read FScrollSpeed write SetScrollSpeed;
  end;

implementation

uses
  SysUtils, Graphics, Math;

{ TcaScrollLabel }

procedure TcaScrollLabel.CMTextChanged(var Message: TMessage);
begin
  inherited;
  StartScrolling();
end;

constructor TcaScrollLabel.Create(AOwner: TComponent);
begin
  inherited;
  AutoSize := False;
  FScrollTimer := TTimer.Create(nil);
  FScrollTimer.OnTimer := ScrollTimer;
  FScrollTimer.Interval := 100;
  FScrollSpeed := 100;
  FScrollPos := 0;
  FTextWidth := 0;
end;

destructor TcaScrollLabel.Destroy;
begin
  FreeAndNil(FScrollTimer);
  inherited;
end;

procedure TcaScrollLabel.DoEndScroll;
begin
  FScrolling := False;
  if Assigned(OnEndScroll) then
    OnEndScroll(Self);
  if RepeatScroll then
    StartScrolling();
end;

procedure TcaScrollLabel.DoStartScroll;
begin
  FScrolling := True;
  if Assigned(OnStartScroll) then
    OnStartScroll(Self);
end;

procedure TcaScrollLabel.Paint;
var
  lRect: TRect;
begin
  if not Assigned(Parent) then
    Exit;
  lRect := ClientRect;
  if not (csDesigning in ComponentState) then
    lRect.Left := (lRect.Right - FScrollPos);
  Canvas.Font := Font;
  if not Transparent then
  begin
    Canvas.Brush.Color := Color;
    Canvas.Brush.Style := bsSolid;
    Canvas.FillRect(lRect);
  end else
    Canvas.Brush.Style := bsClear;
  TextOut(Canvas.Handle, lRect.Left, lRect.Top, PChar(Caption), Length(Caption));
end;

procedure TcaScrollLabel.ScrollTimer(Sender: TObject);
begin
  if FScrollPos >= (FTextWidth + Width) then
  begin
    FScrollTimer.Enabled := False;
    DoEndScroll;
  end
  else
    Inc(FScrollPos, 3);
  if Assigned(Parent) then
    Repaint;
end;

procedure TcaScrollLabel.SetAutoSize(Value: Boolean);
begin
  inherited SetAutoSize(False);
end;

procedure TcaScrollLabel.SetOnEndScroll(const Value: TNotifyEvent);
begin
  FOnEndScroll := Value;
end;

procedure TcaScrollLabel.SetOnStartScroll(const Value: TNotifyEvent);
begin
  FOnStartScroll := Value;
end;

procedure TcaScrollLabel.SetRepeatScroll(const Value: Boolean);
begin
  FRepeatScroll := Value;
end;

procedure TcaScrollLabel.SetScrollSpeed(const Value: Cardinal);
begin
  FScrollSpeed := Value;
  FScrollTimer.Interval := Value;
end;

procedure TcaScrollLabel.StartScrolling;
var
  lRect: TRect;
  lFlags: Cardinal;
begin
  if not Assigned(Parent) then
    Exit;
  if Assigned(FScrollTimer) then
  begin
    DoStartScroll;
    FScrollPos := 0;
    FScrollTimer.Enabled := not (csDesigning in ComponentState);
    lRect := Rect(0,0,0,0);
    Canvas.Font := Font;
    lFlags := DT_LEFT or DT_CALCRECT or DT_SINGLELINE or DT_NOPREFIX;
    DrawText(Canvas.Handle, PChar(Caption), Length(Caption), lRect, lFlags);
    FTextWidth := lRect.Right - lRect.Left;
  end;
end;

end.