Mega Code Archive
Sinus scroller component
<![CDATA[
Title: Sinus scroller component
Question: Does the Job like Title say'z !
Scroll'n'roll.Old Fashion Intro Style!
Answer:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TScroller=class(TCustomControl,IChangeNotifier)
procedure IChangeNotifier.Changed = FontChanged;
private
sHdc,sBmp:integer;
xHdc,xBmp:integer;
oHdc,oBmp:integer; //konana mapa!
coef,cTos:integer;
mY:integer; //veliina slova
mFont:TFont;
mSize:TSize;
mTxt:String;
cTmr:TTimer;
BckBrush:HBRUSH;
BckClr:Tcolor;
ForClr:Tcolor;
pPos:integer;
pSpeed:integer;
pSSpeed:integer;
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
procedure PaintWindow (var TM:TMessage);message WM_PAINT;
procedure EraseBackGround (var TM:TMessage);message WM_ERASEBKGND;
procedure SizeCtrl (var TM:TMessage);message WM_SIZE;
procedure SinusIt;
procedure ProcessLns;
protected
procedure TimerEvent(Sender: TObject);
procedure FontChanged;
procedure SetFont(f:Tfont);
procedure SetText(const T:string);
procedure ClearPosition;
procedure WriteOn;
function ScrollerState:boolean;
procedure SetBckClr (c:TColor);
procedure SetForClr (c:TColor);
procedure SetSpeed (s:integer);
procedure SetSSpeed (s:integer);
public
procedure StartScroll;
procedure PauseScroll;
property State:boolean read ScrollerState;
published
property Font:TFont read mFont write SetFont;
property ForegroundColor:TColor read ForClr write SetForClr;
property BackgroundColor:TColor read BckClr write SetBckClr;
property Speed:integer read pSpeed write SetSpeed default 1;
property Evaluation:integer read coef write coef;
property SinusSpeed:integer read pSSpeed write SetSSpeed default 1;
end;
var
Form1: TForm1;
t:TScroller;
implementation
{$R *.dfm}
procedure TScroller.PauseScroll;
begin
cTmr.Enabled:=not cTmr.Enabled;
end;
function TScroller.ScrollerState:boolean;
begin
result:=cTmr.Enabled;
end;
procedure TScroller.SetSpeed(s:integer);
begin
if selse if s10 then s:=10;
pSpeed:=s;
end;
procedure TScroller.SetSSpeed(s:integer);
begin
if selse if s10 then s:=10;
pSSpeed:=s;
end;
procedure TScroller.SizeCtrl (var TM:TMessage);
var
x,y:integer;
DskW,DskDc:integer;
begin
x:=tm.LParam and $ffff;
y:=tm.lParam shr 16;
if xHdc0 then begin
DeleteObject(xBmp);DeleteObject(xHdc);
end;
DskW:=GetDesktopwindow;
DskDc:=GetDc(DskW);
xHdc:=CreateCompatibleDc(DskDc);
xBmp:=CreateCompatiblebitmap(DskDc,x,y);
selectobject(xHdc,xBmp);
oHdc:=CreateCompatibleDc(DskDc);
oBmp:=CreateCompatiblebitmap(DskDc,width,height);
selectobject(oHdc,oBmp);
ReleaseDc(DskW,DskDc);
end;
procedure TScroller.PaintWindow(var TM:TMessage);
var
PS:TPaintStruct;
begin
BeginPaint(handle,PS);
EndPaint(handle,PS);
end;
procedure TScroller.EraseBackGround (var TM:TMessage);
var
TR:TRect;
begin
TR:=ClientRect;
drawedge(oHdc,TR,EDGE_SUNKEN,BF_RECT);
bitblt(canvas.Handle,0,0,width,height,oHdc,0,0,SRCCOPY)
end;
procedure TScroller.SetFont(f:Tfont);
begin
mFont.Assign(f);
end;
procedure TScroller.FontChanged;
begin
if length(mTxt)0 then begin
ClearPosition;SetText(mTxt);
end;
end;
procedure Tscroller.SetBckClr (c:TColor);
begin
if c=BckClr then exit;
BckClr:=c;
Deleteobject(BckBrush);
BckBrush:=CreateSolidBrush(c);
if length(mTxt)0 then SetText(mTxt);
end;
procedure Tscroller.SetForClr (c:TColor);
begin
if c=ForClr then exit;
ForClr:=c;
if length(mTxt)0 then SetText(mTxt);
end;
procedure TScroller.ClearPosition;
begin
pPos:=0;
end;
destructor TScroller.Destroy;
begin
Deleteobject(BckBrush);
DeleteObject(sBmp);DeleteObject(sHdc);
DeleteObject(xBmp);DeleteObject(xHdc);
DeleteObject(oBmp);DeleteObject(oHdc);
mFont.Destroy;
cTmr.Destroy;
inherited;
end;
constructor TScroller.Create (Aowner:TComponent);
var
DskDC,DskW:integer;
begin
inherited;
mFont:=Tfont.Create;
mFont.FontAdapter:=self;
cTmr:=TTimer.Create(self);
cTmr.Interval:=1;
cTmr.Enabled:=False;
cTmr.OnTimer:=TimerEvent;
BckClr:=$0;ForClr:=$ee2e33;
BckBrush:=CreateSolidBrush(BckClr);
parent:=(Aowner as TwinControl);
coef:=24;
pSpeed:=1;pSSpeed:=1;
end;
procedure Tscroller.TimerEvent(Sender: TObject);
//var
//x:integer;
begin
//for x:=1 to pSpeed do begin
WriteOn;
ProcessLns;
//end;
end;
procedure TScroller.StartScroll;
begin
cTmr.Enabled:=true;
end;
procedure TScroller.SetText(const T:string);
var
DskDc,DskW:integer;
pRect:TRect;
begin
if length(T)=0 then exit;
mTxt:=T;
if sHdc0 then begin
DeleteObject(sBmp);DeleteObject(sHdc);
end;
DskW:=GetDesktopwindow;
DskDc:=GetDc(DskW);
sHdc:=CreateCompatibleDc(DskDc);
SelectObject(sHdc,mFont.Handle);
GetTextExtentPoint32(sHdc,pansichar(T),length(T),mSize);
sBmp:=CreateCompatiblebitmap(DskDc,mSize.cx,mSize.cy);
mY:=mSize.cy;
selectobject(sHdc,sBmp);
prect.Left:=0;prect.top:=0;prect.Right:=mSize.cx;prect.Bottom:=mSize.cy;
fillrect(sHdc,prect,BckBrush);
setbkmode(sHdc,TRANSPARENT);
settextcolor(sHdc,ForClr);
DrawTextEx(sHdc,pansichar(t),length(t),prect,DT_SINGLELINE ,0);
ReleaseDc(DskW,DskDc);
end;
procedure TScroller.WriteOn;
var
xpos:integer;
ypos:integer;
ch:TRect;
begin
ch:=ClientRect;
if pPos(mSize.cx+ch.Right) then pPos:=0;
xpos:=ch.Right-pPos;
with ch do begin
top:=0;left:=0;bottom:=mY;right:=width;
end;
fillrect (xHdc,ch,BckBrush);
bitblt(xHdc,xpos,0,pPos,mY,sHdc,0,0,SRCCOPY);
SinusIt;
inc (pPos,pSpeed);
end;
procedure TScroller.ProcessLns;
begin
dec(cTos,pSSpeed);
end;
procedure TScroller.SinusIt;
var
x:integer;
y:double;
z:integer;
kY:integer;
begin
kY:=(height-mY) div 2;
fillrect(oHdc,clientrect,BckBrush);
for x:=0 to Width do begin
y:=Sin((cTos+x) *(pi / (width div 2))) * coef;
asm
fld qword ptr [y]
fistp dword ptr [z]
end;
bitblt(oHdc,x,kY+z,1,my,xHdc,x,0,SRCCOPY);
end;
invalidate;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
t:=Tscroller.Create(self);
t.font:=Font;
t.ForegroundColor:=$990022;
t.width:=700;t.Height:=500;
t.Evaluation:=160;
t.Speed:=2;
t.SinusSpeed:=3;
t.SetText('sinus scroll by vanja fuckar,email:inga@vip.hr);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if (Sender as Tbutton)= Button1 then
begin
t.StartScroll;
end
else if (Sender as Tbutton)=Button2 then
begin
t.PauseScroll;
end;
end;
]]>