lasarus_compotents/ScrollingText/scrollingtext.pas

unit scrollingtext;
{$mode delphi}
interface
uses Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls, LCLIntf, strutils;
function SearchAndReplaceStr(const AStr, ASearchStr, AReplaceStr: AnsiString): string; stdcall;
function FormatFromList(const AFrmtdStr: string; const AArgs: TStrings): string; stdcall;
type TScrollingText = class(TGraphicControl)
 private
  FActive: boolean;
  FActiveLine: integer;
  FBuffer: TBitmap;
  FEndLine: integer;
  FLineHeight: integer;
  FLines: TStrings;
  FNumLines: integer;
  FOffset: integer;
  FStartLine: integer;
  FStepSize: integer;
  FTimer: TTimer;
  FReplaceList: TStrings;
  function ActiveLineIsURL: boolean;
  procedure DoTimer(Sender: TObject);
  procedure Init;
  procedure DrawScrollingText(Sender: TObject);
  function GetFont (var VString: string): TFont;
 protected
  procedure SetActive(const AValue: boolean);
  procedure DoOnChangeBounds; override;
  procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
  procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
 public
  constructor Create(AOwner: TComponent); override;
  destructor Destroy; override;
  property Active: boolean read FActive write SetActive;
  property Align;
  property Height;
  property Left;
  property Lines: TStrings read FLines write FLines;
  property ReplaceList: TStrings read FReplaceList write FReplaceList;
  property Top;
  property Width;
 end;
implementation
function SearchAndReplaceStr(const AStr, ASearchStr, AReplaceStr: AnsiString): string;
var CurrDelim, NextDelim: Integer;
    ElemName, s: string;
begin
s:= '';
CurrDelim:= 1;
repeat
 NextDelim:= PosEx(ASearchStr, AStr, CurrDelim);
 if NextDelim = 0 then
  NextDelim:= Length(AStr) + 1;
 ElemName:= Copy(AStr, CurrDelim, NextDelim - CurrDelim);
 if not (NextDelim > Length(AStr)) then
  s:= s + ElemName + AReplaceStr
  else
  s:= s + ElemName;
 CurrDelim:= NextDelim + Length(ASearchStr);
 until CurrDelim > Length(AStr);
Result:= s;
end;
function FormatFromList(const AFrmtdStr: string; const AArgs: TStrings): string;
var i: integer;
    s: string;
begin
s:= AFrmtdStr;
if AArgs.Count > 0 then
 for i:= 0 to AArgs.Count - 1 do
  s:= SearchAndReplaceStr(s, AArgs.Names[i], AArgs.ValueFromIndex[i]);
Result:= s;
end;
function TScrollingText.ActiveLineIsURL: boolean;
begin
if (FActiveLine > 0) and (FActiveLine < FLines.Count) then
 Result:= (Pos('http://', FLines[FActiveLine]) = 1) or (Pos('https://', FLines[FActiveLine]) = 1)
 else
 Result:= False;
end;
procedure TScrollingText.DoTimer(Sender: TObject);
var w, i, j, k: integer;
    s, t, FS: string;
begin
if not Active then
 Exit;
Dec(FOffset, FStepSize);
if FOffSet < 0 then
 FStartLine:= -FOffset div FLineHeight
 else
 FStartLine:= 0;
FEndLine:= FStartLine + FNumLines + 1;
if FEndLine > FLines.Count - 1 then
 FEndLine:= FLines.Count - 1;
FBuffer.Canvas.FillRect(Rect(0, 0, FBuffer.Width, FBuffer.Height));
for i:= FEndLine downto FStartLine do
 begin
 s:= Trim(FLines[i]);
 FBuffer.Canvas.Font.Style:= [];
 FBuffer.Canvas.Font.Color:= clBlack;
 if Length(s) > 0 then
  begin
  if (Pos('http://', s) = 1) or (Pos('https://', s) = 1) then
   begin
   if i = FActiveLine then
    begin
    FBuffer.Canvas.Font.Style:= [fsUnderline];
    FBuffer.Canvas.Font.Color:= clRed;
    end
    else
    FBuffer.Canvas.Font.Color:= clBlue;
    end
    else
    FBuffer.Canvas.Font:= GetFont(s);
  s:= FormatFromList(s, ReplaceList);
  w:= FBuffer.Canvas.TextWidth(s);
  FBuffer.Canvas.TextOut((FBuffer.Width - w) div 2, FOffset + i * FLineHeight, s);
  end;
 end;
 if FStartLine > FLines.Count - 1 then
  FOffset:= FBuffer.Height;
 Invalidate;
end;
procedure TScrollingText.SetActive(const AValue: boolean);
begin
FActive:= AValue;
if FActive then
 Init;
FTimer.Enabled:= Active;
end;
procedure TScrollingText.Init;
begin
FBuffer.Width:= Width;
FBuffer.Height:= Height;
FLineHeight:= FBuffer.Canvas.TextHeight('X');
FNumLines:= FBuffer.Height div FLineHeight;
if FOffset = -1 then
 FOffset:= FBuffer.Height;
with FBuffer.Canvas do
 begin
 Brush.Color:= clWhite;
 Brush.Style:= bsSolid;
 FillRect(0, 0, Width, Height);
 end;
end;
procedure TScrollingText.DrawScrollingText(Sender: TObject);
begin
if Active then
 Canvas.Draw(0, 0, FBuffer);
end;
procedure TScrollingText.DoOnChangeBounds;
begin
inherited DoOnChangeBounds;
Init;
end;
procedure TScrollingText.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
if ActiveLineIsURL then
 OpenURL(FLines[FActiveLine]);
end;
procedure TScrollingText.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited MouseMove(Shift, X, Y);
FActiveLine:= (Y - FOffset) div FLineHeight;
Cursor:= crDefault;
if (FActiveLine >= 0) and (FActiveLine < FLines.Count) and ActiveLineIsURL then
 Cursor:= crHandPoint;
end;
function TScrollingText.GetFont (var VString: string): TFont;
var FS, FSt: string;
    i, EndPos: integer;
    F: TFont;
begin
EndPos:= 0;
F:= TFont.Create;
F.Assign(Font);
if (LowerCase(Copy(VString, 0, 5)) = '{font') then
 begin
 EndPos:= Pos('}', VString) + 1;
 FS:= LowerCase(Copy(VString, 0, EndPos-1));
 i:= Pos('name:', FS);
 if (i > 0) then
  F.Name:= Copy(FS, i+5, PosEx(';', FS, i+5)-i-5);
 i:= Pos('size:', FS);
 if (i > 0) then
  F.Size:= StrToInt(Copy(FS, i+5, PosEx(';', FS, i+5)-i-5));
 i:= Pos('style:', FS);
 if (i > 0) then
  begin
  FSt:= Copy(FS, i+6, PosEx(';', FS, i+6)-i-6);
  if (Pos('bold', LowerCase(FSt)) > 0) then
   F.Style:= F.Style + [fsBold];
  if (Pos('italic', LowerCase(FSt)) > 0) then
   F.Style:= F.Style + [fsItalic];
  if (Pos('underline', LowerCase(FSt)) > 0) then
   F.Style:= F.Style + [fsUnderline];
  if (Pos('strikeout', LowerCase(FSt)) > 0) then
   F.Style:= F.Style + [fsStrikeOut];
  end;
 end;
VString:= Copy(VString, EndPos, Length(VString)-EndPos+1);
Result:= F;
end;
constructor TScrollingText.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle:= ControlStyle + [csOpaque];
OnPaint:= DrawScrollingText;
FLines:= TStringList.Create;
FReplaceList:= TStringList.Create;
FTimer:= TTimer.Create(nil);
FTimer.OnTimer:= DoTimer;
FTimer.Interval:= 30;
FBuffer:= TBitmap.Create;
FStepSize:= 1;
FStartLine:= 0;
FOffset:= -1;
Width:= 200;
Height:= 200;
end;
destructor TScrollingText.Destroy;
begin
FLines.Free;
FReplaceList.Free;
FTimer.Free;
FBuffer.Free;
inherited Destroy;
end;
end.