b1t Что именно у вас есть? Версии LENIN INC WIN32API Library или Delphi разных версий?
Народ, требуется ваша помощь. Захотелось приукрасить программу. Вот ссылка на оригинальный код
http://rapidshare.com/files/67441774/snow.zip.html Решил я это дело через WinApi пустить, но заморочка у меня с таймером, потому как в оригинале идет работа с формой и там есть компонент Timer. А тут нельзя использовать компонент.
Вот что я сделал.
[more=Читать дальше..]
Создал inc файл и поместил следующее:
Код: type
MyPoint = record
X : integer;
Y : integer;
lastColor : COLORREF;
speed : byte;
crazy : integer;
end;
var
screenW,screenH:integer;
points : array of MyPoint;
desktop:hDC;
wind:integer;
show_color:COLORREF;
procedure ShowGradient2(prmDC:hDC;prmRed,prmGreen,prmBlue:byte;ClientWidth,ClientHeight:integer);
var
Row:Word ;
wrkPenNew:hPen;
wrkDelta:integer;
begin
wrkDelta:=100 div (1+ClientHeight);
if wrkDelta=0 then wrkDelta:=1;
for Row := 0 to 1+(ClientHeight) do begin
wrkPenNew:=CreatePen(PS_SOLID,1,RGB(prmRed, prmGreen, prmBlue));
SelectObject(prmDC,wrkPenNew);
MoveToEx(prmDC,0,Row,nil);
LineTo(prmDC,ClientWidth,Row);
DeleteObject(wrkPenNew);
if prmRed > wrkDelta then Dec(prmRed,wrkDelta);
if prmGreen > wrkDelta then Dec(prmGreen,wrkDelta);
if prmBlue > wrkDelta then Dec(prmBlue,wrkDelta);
end;
end;
function IsContrast(Color1,Color2:COLORREF):boolean;
var
r1,g1,b1:byte;
r2,g2,b2:byte;
begin
result:=false;
r1:=GetRValue(Color1);
g1:=GetGValue(Color1);
b1:=GetBValue(Color1);
r2:=GetRValue(Color2);
g2:=GetGValue(Color2);
b2:=GetBValue(Color2);
if ((r1-r2)+(g1-g2)+(b1-b2))>100 then result:=true;
end;
procedure paintSnow(h:hDC);
var
i:integer;
x,y:integer;
color_1,color_2:COLORREF;
down_snow:byte;
begin
case 2-random(2) of
1:inc(wind);
2:dec(wind);
end;
if wind>5 then dec(wind);
if wind<-5 then inc(wind);
for i:=0 to high(points) do begin
x:=points[i].X+points[i].crazy+wind;
y:=points[i].Y+1+points[i].speed;
if (y > screenH) then y:=1;//если долетела до низа экрана то отображаем сверху
if (x > screenW) then x:=1;
if (x < 0) then x:=screenW;
color_1:=GetPixel(h,x,y);//цвет будущей точки
color_2:=GetPixel(h,x,y+1);
if (IsContrast(color_1,color_2)) and (color_1<>show_color) //если контраст большой то снежинка упала
then begin
down_snow:=random(1);
points[i].Y:=points[i].Y+down_snow;
points[i].X:=points[i].X;
case (random(2)) of
1: SetPixelV(h,points[i].X,points[i].Y,show_color);
2: begin
SetPixelV(h,points[i].X-1,points[i].Y,show_color);
SetPixelV(h,points[i].X,points[i].Y,show_color);
end;
0: begin
points[i].Y:=points[i].Y-random(3);
SetPixelV(h,points[i].X+1,points[i].Y+1,show_color);
SetPixelV(h,points[i].X,points[i].Y,show_color);
SetPixelV(h,points[i].X-1,points[i].Y+1,show_color);
end;
end;
y:=random(screenH div 4);
end else begin
if GetPixel(h,points[i].X,points[i].Y)=show_color then
SetPixelV(h,points[i].X,points[i].Y,points[i].lastColor);//восстанавливаем цвет предыдущей точки, ранее затертой
points[i].lastColor:=GetPixel(h,x,y);//запоминаем цвет точки который скоро затерем
SetPixelV(h,x,y,show_color);
end;
points[i].X:=x;
points[i].Y:=y;
points[i].crazy:=-points[i].crazy;//добиваюсь того чтобы снежинка летела влево-вправо
end;
end;
procedure init;
var
i:integer;
begin
for i:=0 to high(points) do begin
points[i].X:=screenW-random(screenW);
points[i].Y:=screenH-random(screenH);
points[i].speed:=3-random(2);
points[i].crazy:=1-random(1);
points[i].lastColor:=GetPixel(desktop,points[i].X+1,points[i].Y);
end;
end;
procedure SnowCreateDC;
begin
show_color:=rgb(234,234,255);
wind:=1;
desktop:=CreateDC('DISPLAY',nil,nil,nil);
screenW:=GetSystemMetrics (SM_CXSCREEN);
screenH:=GetSystemMetrics (SM_CYSCREEN);
randomize;
setlength(points,801);
init;
end;
procedure CreateSnowWindow;
begin
SnowCreateDC;
inttostr(high(points));
inttostr(50);
inttostr(wind);
paintSnow(desktop);
end;
может кто помочь?