BUBOREK

Top  Previous  Next

unit buborek;

 

interface

 

uses

SysUtils, WinTypes, WinProcs, Messages, Classes,

Graphics, Controls, Forms, Dialogs, ExtCtrls;

 

type

TBuborek = class(TImage)

private

  FSebesseg : integer;

  FBubleMass: integer;

  FColor : TColor;

  FBubleColor : TColor;

  Ftimer      : TTimer;

  procedure SetSebesseg(Value:integer);

  procedure SetColor(Value:TColor);

  procedure SetBubleColor(Value:TColor);

protected

  elso:boolean;

  bi: TBitmap;

  procedure Timer(Sender:TObject);

public

  constructor Create(AOwner:TComponent);override;

  destructor Destroy;override;

  Procedure Paint; override;

published

  Property Sebesseg : integer read FSebesseg write SetSebesseg default 1;

  Property Color : TColor read FColor write SetColor ;

  Property BubleColor : TColor read FBubleColor write SetBubleColor ;

  Property BubleMass : integer read FBubleMass write FBubleMass default 1;

end;

 

procedure Register;

 

function KepMove(ca:TCanvas; xm,ym : integer; alapszin: TColor):Trect;

 

implementation

 

procedure Register;

begin

   RegisterComponents('AL',[TBuborek]);

end;

 

constructor TBuborek.Create(AOwner:TComponent);

begin

   inherited Create(AOwner);

   elso:=True;

   FSebesseg  := 1;

   FColor     := clBlue;

   FBubleColor:= clWhite;

   FTimer     := TTimer.Create(Self);

   FTimer.Interval:= Trunc(100/FSebesseg);

   FTimer.Ontimer := Timer;

   FBubleMass := 10;

end;

 

destructor TBuborek.Destroy;

begin

   FTimer.Free;

   bi.free;

   inherited Destroy;

end;

 

 

procedure TBuborek.SetSebesseg(Value:integer);

begin

If FSebesseg<>Value then begin

  FSebesseg:=Abs(Value);

  If Value>0 then FTimer.Interval:= Trunc(100/FSebesseg)

  else FTimer.Interval:=0;

  invalidate;

end;

end;

 

 

procedure TBuborek.SetColor(Value:TColor);

begin

If FColor<>Value then begin

  FColor:=Value;

  invalidate;

end;

end;

 

 

procedure TBuborek.SetBubleColor(Value:TColor);

begin

If FBubleColor<>Value then begin

  FBubleColor:=Value;

  invalidate;

end;

end;

 

procedure TBuborek.Timer;

var i: integer;

  r1,r2: Trect;

begin

Try

With Canvas do begin

  Draw(0,0,bi);

  If elso then begin

     Brush.Color:=color;

     Brush.Style:=bsSolid;

     Pen.Color:=Color;

     Rectangle(0,0,width,height);

     elso:=False;

  end;

  Pen.Color:=BubleColor;

  For i:=1 to BubleMass do begin

     Pixels[Random(width),Height-2]:=BubleColor;

  end;

  KepMove(Canvas,0,-1,Color);

end;

except

On Exception do exit;

end;

end;

 

Procedure TBuborek.Paint;

begin

inherited Paint;

end;

 

function KepMove(ca:TCanvas; xm,ym : integer; alapszin: TColor):Trect;

var fRect,cRect: TRect;

begin

fRect:=ca.cliprect;

cRect:=fRect;

OffSetRect(cRect,XM,YM);

Ca.CopyMode:=cmSrcCopy;

Ca.CopyRect(cRect,Ca,fRect);

If (xm<>0) or (ym<>0) then begin

  If xm>0 then fRect:=Rect(0,0,xm,frect.bottom-frect.top);

  If xm<0 then fRect:=Rect(frect.right-frect.left+xm,0,

     frect.right-frect.left,frect.bottom-frect.top);

  If ym>0 then fRect:=Rect(0,0,frect.right-frect.left,ym);

  If ym<0 then fRect:=Rect(0,frect.bottom-frect.top+ym,

     frect.right-frect.left,frect.bottom-frect.top);

  ca.Brush.Style:=bsSolid;

  ca.Brush.Color:=alapszin;

  ca.FillRect(fRect);

  Result:=frect;

end;

end;

 

end.