unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
TScrollLabel = class(TGraphicControl)
private
FLines: TStrings;
FTopLine: Integer;
FLineHeight: Integer;
function GetCaption: String;
function GetFont: TFont;
procedure SetCaption(const AValue: String);
procedure SetFont(const AValue: TFont);
procedure SetLines(const AValue: TStrings);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
function PageLines: Integer;
procedure ScrollBy(ADelta: Integer);
procedure ScrollTo(ALine: Integer);
published
property Caption: String read GetCaption write SetCaption;
property Color;
property Lines: TStrings read FLines write Setlines;
property Font: TFont read GetFont write SetFont;
end;
type
{ TForm1 }
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
private
FScrollLabel: TScrollLabel;
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
uses
LCLType;
constructor TScrollLabel.Create(AOwner: TComponent);
begin
inherited;
FLines := TStringList.Create;
end;
destructor TScrollLabel.Destroy;
begin
FLines.Free;
inherited;
end;
function TScrollLabel.GetCaption: String;
begin
Result := FLines.Text;
end;
function TScrollLabel.GetFont: TFont;
begin
Result := inherited Font;
end;
function TScrolLLabel.PageLines: Integer;
begin
Result := Height div FLineHeight;
end;
procedure TScrollLabel.Paint;
var
y: Integer;
i: Integer;
begin
Canvas.Font.Assign(Font);
if FLineHeight = 0 then
FLineHeight := Canvas.TextHeight('Tg');
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(0, 0, Width, Height);
y := 0;
i := FTopLine;
while (y < Height) and (i < FLines.Count) do begin
Canvas.TextOut(0, y, FLines[i]);
inc(y, FLineHeight);
inc(i);
end;
end;
procedure TScrollLabel.ScrollBy(ADelta: Integer);
begin
ScrollTo(FTopLine + ADelta);
end;
procedure TScrollLabel.ScrollTo(ALine: Integer);
var
n: Integer;
begin
if ALine < 0 then
ALine := 0
else begin
n := PageLines;
if ALine + n >= FLines.Count then
ALine := FLines.Count - n;
end;
FTopLine := ALine;
Invalidate;
end;
procedure TScrollLabel.SetCaption(const AValue: String);
begin
FLines.Text := AValue;
FTopLine := 0;
Invalidate;
end;
procedure TScrolLLabel.SetFont(const AValue: TFont);
begin
inherited Font := AValue;
Canvas.Font := AValue;
FLineHeight := Canvas.TextHeight('Tg');
end;
procedure TScrollLabel.SetLines(const AValue: TStrings);
begin
FLines.Assign(AValue);
FTopLine := 0;
Invalidate;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
var
str: String;
i: Integer;
begin
FScrollLabel := TScrollLabel.Create(self);
FScrollLabel.Parent := Self;
FScrollLabel.Align := alClient;
// DoubleBuffered:= True;
KeyPreview := True;
str := '';
for i:= 1 To 15000 do
str := str+'THE LAST OF THE MOHICANS - HELLO WORLD'+IntToStr(i)+sLineBreak;
FScrollLabel.Caption := str + 'END of TEXT';
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
case Key of
VK_UP : FScrollLabel.ScrollBy(-1);
VK_DOWN : FScrollLabel.ScrollBy(+1);
VK_PRIOR : FScrollLabel.ScrolLBy(-FScrollLabel.PageLines);
VK_NEXT : FScrollLabel.ScrollBy(+FScrollLabel.PageLines);
VK_HOME : FScrollLabel.ScrollTo(0);
VK_END : FScrollLabel.ScrollTo(FScrollLabel.Lines.Count);
end;
end;
end.