Компонент ScrollText

//  Scroll Text Component
// Author: Jorge Abel Ayala Marentes
// Created: 25/01/2001

unit ScrollText;

interface

uses
   Windows, Messages, SysUtils, Classes, Graphics, 
   Controls, Forms, Dialogs, ExtCtrls;

type
   TColorType = (ctGreen, ctRed, ctBlue);

   TScrollText = class(TComponent)
   private
     FText: String;
     FTimer: TTimer;
     FTextColor: TColorType;
     vi_Mv, vi_St: Integer;
     procedure SetText(const Value: String);
     procedure CustomOnTimer(Sender: TObject);
     procedure SetTextColor(const Value: TColorType);
   protected
   public
     procedure ScrollText;
     constructor Create(AOwner: TComponent); override;
     destructor Destroy;override;
   published
     property Text: String read FText write SetText;
     property TextColor: TColorType 
         read FTextColor write SetTextColor;
   end;

procedure Register;

implementation

procedure Register;
begin
   RegisterComponents('prueba', [TScrollText]);
end;

{ TScrollText }

constructor TScrollText.Create(AOwner: TComponent);
begin
   inherited;
   vi_Mv := 0;
   vi_St := 1;

   FTimer := TTimer.Create(Self);
   with FTimer do
   begin
     Enabled := True;
     Interval := 5;
     OnTimer := CustomOnTimer;
   end;

   if not (AOwner.InheritsFrom(TForm)) then
     raise Exception.Create('
        Этот компонент может быть помещен только на форму!'); 

   //Устанавливаем Forms Height
   with (Owner as TForm) do
   begin
     Height := 90;
     Color := clBlack;
     BorderStyle := bsDialog;
     Caption := '';
   end;

   ScrollText; 
end;//конец TScrollText.Create

procedure TScrollText.CustomOnTimer(Sender: TObject);
begin
   ScrollText; 

   //Перемещаем текст
   Inc(vi_Mv, vi_St);
end;//конец TScrollText.CustomOnTimer

destructor TScrollText.Destroy;
begin
   FTimer.Free;
   inherited;
end;//конец TScrollText.Destroy

procedure TScrollText.ScrollText;
var
   Bitmap: TBitmap;
   Rect: TRect;
   vi_Counter: Integer;
begin
   if not (csDesigning in Self.ComponentState) then
   begin
     //Создаем Bitmap для рисования текста
     Bitmap := TBitmap.Create;
     try
     //устанаавливаем высоту Bitmap равную высоте сообщения
     Bitmap.Height := Bitmap.Canvas.TextHeight(Text);

     //Если текст закончился, тогда перематываем
     if vi_Mv >= Bitmap.Canvas.Textwidth(Text) then
       vi_St:=-16;

     //если это начало, идем вперед
     if vi_Mv <= 0 then
       vi_St:=1; 

     //Устанавливаем ширину Bitmap
     Bitmap.Width := (Owner as TForm).Width div 4;

     with Bitmap.Canvas do
     begin
       //Заполняем его Темно-зеленым цветом
       Brush.Style:=bssolid;
       //Цвет BBGGRR в hex - ищем TColor
       case TextColor of
         ctGreen: begin
                     Brush.Color := $005000;
                     Fillrect(ClipRect);
                     Font.Color:=$00FF00;
                   end;
         ctRed:   begin
                     Brush.Color := $000050;
                     Fillrect(ClipRect);
                     Font.color := $0000FF;
                   end;
         ctBlue:  begin
                     Brush.Color := $500000;
                     Fillrect(ClipRect);
                     Font.color := $FF0000;
                   end;
       end;
       Textout(-vi_Mv, 0, Text);
       Rect := Cliprect;
       //Увеличим изображение в два раза от его размера
       Bitmap.Height := Bitmap.Height * 2;
       Bitmap.Width := Bitmap.Width * 2;

       CopyRect(ClipRect, Bitmap.canvas, Rect);
       //Устанавливаем перо в сплошной черный
       Pen.Style := pssolid;
       Pen.Color := clblack;

       // Рисуем сетку линий поперек изображения в X+Y
       for vi_Counter := 0 to Bitmap.Height div 2 do
       begin
         MoveTo(0, vi_Counter*2);
         LineTo(Bitmap.width, vi_Counter*2);
       end;

       for vi_Counter:=0 to Bitmap.width div 2 do
       begin
       MoveTo(vi_Counter*2,0);
       LineTo(vi_counter*2,Bitmap.height);
       end;

       // Растягиваем изображение снова и рисуем 
       // двойной размер на форме
       Rect := Bitmap.Canvas.ClipRect;
       Rect.Bottom := Rect.Bottom*2;
       Rect.Right:= Rect.Right*2;
       (Owner asTForm).Canvas.StretchDraw(Rect,Bitmap);


     end;
     finally
       Bitmap.Free;
     end;
   end;
end;//конец TScrollText.ScrollText

procedure TScrollText.SetText(const Value: String);
begin
   if Value <> FText then
     FText := Value;

   ScrollText;
end;//конец TScrollText.SetText

procedure TScrollText.SetTextColor(
    const Value: TColorType); 
begin
   if FTextColor <> Value then
     FTextColor := Value;
end;//конец TScrollText.SetTextColor

end.