//---------------------------------------------------------------------------- // Scroll Text Class // Co: TFmedia // Created date: 01/04/2009 // Created by duhao //---------------------------------------------------------------------------- unit TextScroll; 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; hScreenDC:HDC;//定义桌面窗口的图形设备描述表句柄; canvs:TCanvas; 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; hScreenDC := GetDC(0); canvs:=TCanvas.Create; canvs.Handle:=hScreenDC; FTimer := TTimer.Create(Self);//timer with FTimer do begin Enabled := True; Interval := 5; OnTimer := CustomOnTimer; end;
if not (AOwner.InheritsFrom(TForm)) then raise Exception.Create('This Component can only be dropped on Forms!'); ScrollText; end;//end of TScrollText.Create //----------------------------------------------------------------------------
procedure TScrollText.CustomOnTimer(Sender: TObject); begin ScrollText; //Move text Inc(vi_Mv, vi_St); end;//end of TScrollText.CustomOnTimer //----------------------------------------------------------------------------
destructor TScrollText.Destroy; begin FTimer.Free; ReleaseDC(0,hScreenDC); inherited; end;//end of TScrollText.Destroy //---------------------------------------------------------------------------- procedure TScrollText.ScrollText; var Bitmap: TBitmap; Rect: TRect; vi_Counter: Integer; begin if not (csDesigning in Self.ComponentState) then begin //Create a Bitmap to draw the text Bitmap := TBitmap.Create; try //set Bitmap´s Height to equal the Message´s Height Bitmap.Height := Bitmap.Canvas.TextHeight(Text); //If the text has reaced the end then rewind if vi_Mv >= Bitmap.Canvas.Textwidth(Text) then vi_St:=-16; //if its at the beginning, go forward if vi_Mv <= 0 then vi_St:=1; //Set Bitmap´s Width Bitmap.Width := (Owner as TForm).Width div 4; with Bitmap.Canvas do begin //We are Filling it with Solid Dark Green Brush.Style:=bssolid; //The colour goes BBGGRR in hex - look up 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; //Enlarge the image to twice its original size Bitmap.Height := Bitmap.Height * 2; Bitmap.Width := Bitmap.Width * 2;
CopyRect(ClipRect, Bitmap.canvas, Rect); //Set up pen for solid black Pen.Style := pssolid; Pen.Color := clblack; //Draw a grid of lines across the bitmap in 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;
//Stretch bitmap again and draw twice its size on the form Rect := Bitmap.Canvas.ClipRect; Rect.Top:=Rect.Top+720; Rect.Bottom := Rect.Bottom*2+720; Rect.Right:= Rect.Right*2; canvs.StretchDraw(Rect,Bitmap); end; finally Bitmap.Free; end; end; end;//end of TScrollText.ScrollText //----------------------------------------------------------------------------
procedure TScrollText.SetText(const Value: String); begin if Value <> FText then FText := Value; ScrollText; end;//end of TScrollText.SetText //----------------------------------------------------------------------------
procedure TScrollText.SetTextColor(const Value: TColorType); begin if FTextColor <> Value then FTextColor := Value; end;//end of TScrollText.SetTextColor //----------------------------------------------------------------------------
SOGUA KK的歌词就是我做的.
// Scroll Text Class
// Co: TFmedia
// Created date: 01/04/2009
// Created by duhao
//----------------------------------------------------------------------------
unit TextScroll; 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;
hScreenDC:HDC;//定义桌面窗口的图形设备描述表句柄;
canvs:TCanvas;
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;
hScreenDC := GetDC(0);
canvs:=TCanvas.Create;
canvs.Handle:=hScreenDC; FTimer := TTimer.Create(Self);//timer
with FTimer do
begin
Enabled := True;
Interval := 5;
OnTimer := CustomOnTimer;
end;
if not (AOwner.InheritsFrom(TForm)) then
raise Exception.Create('This Component can only be dropped on Forms!');
ScrollText;
end;//end of TScrollText.Create
//----------------------------------------------------------------------------
procedure TScrollText.CustomOnTimer(Sender: TObject);
begin
ScrollText;
//Move text
Inc(vi_Mv, vi_St);
end;//end of TScrollText.CustomOnTimer
//----------------------------------------------------------------------------
destructor TScrollText.Destroy;
begin
FTimer.Free;
ReleaseDC(0,hScreenDC);
inherited;
end;//end of TScrollText.Destroy
//---------------------------------------------------------------------------- procedure TScrollText.ScrollText;
var
Bitmap: TBitmap;
Rect: TRect;
vi_Counter: Integer;
begin
if not (csDesigning in Self.ComponentState) then
begin
//Create a Bitmap to draw the text
Bitmap := TBitmap.Create;
try
//set Bitmap´s Height to equal the Message´s Height
Bitmap.Height := Bitmap.Canvas.TextHeight(Text); //If the text has reaced the end then rewind
if vi_Mv >= Bitmap.Canvas.Textwidth(Text) then
vi_St:=-16; //if its at the beginning, go forward
if vi_Mv <= 0 then
vi_St:=1; //Set Bitmap´s Width
Bitmap.Width := (Owner as TForm).Width div 4; with Bitmap.Canvas do
begin
//We are Filling it with Solid Dark Green
Brush.Style:=bssolid;
//The colour goes BBGGRR in hex - look up 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;
//Enlarge the image to twice its original size
Bitmap.Height := Bitmap.Height * 2;
Bitmap.Width := Bitmap.Width * 2;
CopyRect(ClipRect, Bitmap.canvas, Rect);
//Set up pen for solid black
Pen.Style := pssolid;
Pen.Color := clblack; //Draw a grid of lines across the bitmap in 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;
//Stretch bitmap again and draw twice its size on the form
Rect := Bitmap.Canvas.ClipRect;
Rect.Top:=Rect.Top+720;
Rect.Bottom := Rect.Bottom*2+720;
Rect.Right:= Rect.Right*2;
canvs.StretchDraw(Rect,Bitmap);
end;
finally
Bitmap.Free;
end;
end;
end;//end of TScrollText.ScrollText
//----------------------------------------------------------------------------
procedure TScrollText.SetText(const Value: String);
begin
if Value <> FText then
FText := Value; ScrollText;
end;//end of TScrollText.SetText
//----------------------------------------------------------------------------
procedure TScrollText.SetTextColor(const Value: TColorType);
begin
if FTextColor <> Value then
FTextColor := Value;
end;//end of TScrollText.SetTextColor
//----------------------------------------------------------------------------
end.