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.