编个程序送女朋友
各位高手，圣诞快到了，想编个程序送喜欢的女生（都暗恋两三年的了），可惜技术不行啊，呵呵，哪位大哥大姐愿意帮小弟这个忙啊，想做个感人点的（想要表白啊）。在网上搜了个控件不知道能不能帮上什么忙，各位：靠你们啦！小弟在这先谢过啦！ 就算帮我完成这个程序也行啊。我邮箱：[email protected]
星空模拟控件，再加个字幕控件（比如：RX的TSecretPanel）
unit LightSpd;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, ExtCtrls ;
type
PStar =^TStar;
TStar =record
C, {color}
X,Y, {center X,Y}
W :integer;{width}
L,T,R,B, {coordiants}
S :single; {step}
end;
TLightSpeedSpeed =(lsSlower,lsSlow,lsNormal,lsFast,lsFaster,lsLight);
TLightSpeedOption =(loColored,loMultiplay);
TLightSpeedOptions = set of TLightSpeedOption;
TLightSpeed = class(TGraphicControl)
private
FStarsCount :byte;
FBrightness :byte;
FSpeed :TLightSpeedSpeed;
FOptions :TLightSpeedOptions;
FInterval :integer;
FCenterX,FCenterY :integer;
FActive :boolean;
Timer: TTimer;
Stars: array[1..255] of tStar;
LX,LY,LS :integer;
procedure SetInterval (Value :integer);
procedure SetActive (Value :boolean);
protected
procedure Go(Sender: TObject);
procedure Paint; override;
public
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
published
property StarsCount :byte read FStarsCount write FStarsCount default 100;
property Brightness :byte read FBrightness write FBrightness default 96;
property Speed :TLightSpeedSpeed read FSpeed write FSpeed default lsNormal;
property Options :TLightSpeedOptions read FOptions write FOptions;
property Interval :integer read FInterval write SetInterval default 50;
property Active :boolean read FActive write SetActive default false;
property ParentShowHint;
property ShowHint;
property Color default clBlack;
property ParentColor;
property Width default 200;
property Height default 160;
property Align default alNone;
property Visible;
property CenterX :integer read FCenterX write FCenterX;
property CenterY :integer read FCenterY write FCenterY;
end;
procedure Register;
implementation
function Min (X,Y :integer) :integer;
begin
if X
constructor TLightSpeed.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
ControlStyle := ControlStyle + [csReplicatable];
FStarsCount:=100;
FBrightness:=96;
FSpeed:=lsNormal;
FOptions:=[loColored,loMultiplay];
FInterval:=50;
FActive:=false;
Width:=200;
Height:=160;
Align:=alNone;
Color:=clBlack;
FCenterX:=Width div 2; FCenterY:=Height div 2;
LX:=Min(FCenterX,FCenterY); LY:=LX;
LS:=round(sqrt(LX*LX/2));
randomize;
fillchar(Stars,sizeof(Stars),$FF);
Timer:=TTimer.Create(Self);
Timer.Interval:=0;
Timer.OnTimer:=Go;
end;
destructor TLightSpeed.Destroy;
begin
Timer.Free;
inherited;
end;
procedure TLightSpeed.SetInterval(Value :integer);
begin
if Value<>FInterval then begin
FInterval:=Value;
Timer.Interval:=FInterval;
end;
end;
procedure TLightSpeed.SetActive(Value :boolean);
begin
if Value<>FActive then begin
FActive:=Value;
if FActive then Timer.Interval:=FInterval
else Timer.Interval:=0;
end;
end;
{procedure TLightSpeed.SetColor(Value :tColor);
begin
if Value<>Color then begin
Canvas.Brush.Color:=Value;
Repaint;
end;
inherited;
end;
}
procedure TLightSpeed.Paint;
begin
Canvas.Brush.Color := Color;
Canvas.FillRect(Rect(0,0,Width,Height));
{ Canvas.Pen.Color := clBtnShadow;
Canvas.PolyLine([Point(0,Height-1), Point(0,0), Point(Width-1,0)]);
Canvas.Pen.Color := clBtnHighlight;
Canvas.PolyLine([Point(Width-1,0), Point(Width-1,Height-1), Point(0,Height-1)]);}
end;
procedure TLightSpeed.Go(Sender: TObject);
var
Dot :integer;
red,green,blue :byte;
begin
LX:=Min(Height div 4,Width div 4); LY:=LX;
LS:=round(sqrt(LX*LX/2));
if not Visible and not (csDesigning in ComponentState) then exit;
for Dot:=1 to 255 do with Stars[Dot] do begin
if C<>-1 then begin
{clear line}
Canvas.Pen.Width:=W;
Canvas.Pen.Color:=Color;
Canvas.MoveTo(round(X+L),round(Y+T));
Canvas.LineTo(round(X+R),round(Y+B));
end
else begin
{define new line}
if Dot>FStarsCount then continue;
repeat
L:=random(LX)-LX div 2;
T:=random(LY)-LY div 2;
S:=sqrt(L*L+T*T);
until (S>6);
S:=1+succ(ord(FSpeed))/(S*S/LS*5);
R:=L*S*1.01; B:=T*S*1.01; {length 1 - 1.1}
blue:=random($40);
if loColored in FOptions then begin green:=random($40); red:=random($40); end
else begin green:=blue; red:=blue; end;
C:=FBrightness shl 16 + FBrightness shl 8 + FBrightness +
blue shl 16 + green shl 8 + red;
W:=1+byte(random(20)=0)+byte(random(20)=0);
end;
X:=FCenterX; Y:=FCenterY;
{draw line}
L:=L*S; R:=R*S;
T:=T*S; B:=B*S;
if loMultiplay in FOptions then begin
blue := Min($FF, C shr 16 + random(round((S*S*S*S))));
if loColored in FOptions then begin
green:= Min($FF, C shr 8 and $FF + random(round((S*S*S*S))));
red := Min($FF, C and $FF + random(round((S*S*S*S))));
end
else begin green:=blue; red:=blue; end;
C:=integer(blue) shl 16 + green shl 8 + red;
end;
Canvas.Pen.Width:=W; Canvas.Pen.Color:=C;
Canvas.MoveTo(round(X+L),round(Y+T));
Canvas.LineTo(round(X+R),round(Y+B));
if ((X+L<-5) or (X+L>ClientWidth+5))
or ((Y+T<-5) or (Y+T>ClientHeight+5))
then C:=-1;
end;
end;
procedure Register;
begin
RegisterComponents('Samples', [TLightSpeed]);
end;
end.