Опытный
Профиль
Группа: Участник
Сообщений: 425
Регистрация: 16.1.2005
Где: Киев
Репутация: 5
Всего: 16
|
Вот пример компонента, реализующего огонь: | Код |
{*************************************************************}
{ TFlame Components for Delphi 16/32 }
{ Version: 1.5 }
{ Authors: Matthias Laschat - 16-bit component }
{ }
{ Aleksey Kuznetsov- Upgraded to Win32, }
{ Added transparent image, }
{ Added bottom range, }
{ Improvement }
{ (http://www.utilmind.com) }
{ }
{ Emir Kurtovic - Multicolour Flame, }
{ Fading of flame, }
{ Improvement (MIKS) }
{ (http://www.net.yu/~miks) }
{*************************************************************}
{ Last modified: March, 7, 1999 }
{*************************************************************}
{ If at occurrence of any questions concerning this }
{ component, mail: [email protected] }
{ For updated versions, visit: http://www.utilmind.com }
{*************************************************************}
unit Flame;
interface
uses
{$IFDEF WIN32} Windows,
{$ELSE} WinTypes, WinProcs,
{$ENDIF} Messages, Classes, Graphics, Controls, Forms;
type
PFlameField = ^TFlameField;
TFlameField = Array[0..100,0..159] of Word;
PBitmapData = ^TBitmapData;
TBitmapData = Array[0..199,0..319] of Byte;
type
DoSto = 0..100; {MIKS} { До ста }
DoDvesta = 0..199; {MIKS} { До двухсот }
TFireColor = (FireRed, FireGreen, FireBlue, FireDeepPurple, FireCyan, FireYellow); {MIKS Add-ON}
TFlame = class(TGraphicControl)
private
FadeProcess: Byte; {MIKS}
FFireColor: TFireColor; {MIKS}
FFadeOut: Boolean; {MIKS}
FEnabled: Boolean;
FInterval: Word;
FWindowHandle: hWnd;
TmpImage, FImage: TBitmap;
FPalette: HPalette;
FBitmap: PBitmapData;
FFlameField: PFlameField;
FBottomRange: DoDvesta;
FSolidFlame: Boolean;
FOnFlame: TNotifyEvent;
procedure UpdateTimer;
procedure SetEnabled(Value: Boolean);
procedure SetInterval(Value: Word);
procedure SetOnFlame(Value: TNotifyEvent);
procedure WndProc(var Msg: TMessage);
procedure MakePalette; virtual;
procedure KillPalette; virtual;
function GetPalette: hPalette; override;
{$IFNDEF WIN32}
procedure DrawTransparentBitmap(ahDC: hDC; xStart, yStart, x1,y1,x2,y2: Word);
{$ENDIF}
protected
procedure FlameIt; dynamic;
public
constructor Create(aowner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
procedure DoFlame; virtual;
procedure MakeRandomLine(y: DoSto); virtual;
procedure MakeDarkLine(y: DoSto); virtual;
procedure SetFlamePixel(x, y: Byte); virtual;
procedure SetImage(aImage: TBitmap); virtual;
procedure SetBottomRange(Value: DoDvesta); virtual;
procedure SetFireColor(Value: TFireColor); virtual; {MIKS}
procedure SetFadeOut(Value: Boolean); virtual; {MIKS}
published
property FadeOut: Boolean read FFadeOut write SetFadeOut default False; {MIKS}
property FireColor: TFireColor read FFireColor write SetFireColor; {MIKS}
property Align;
property Enabled: Boolean read FEnabled write SetEnabled default True;
property Interval: Word read FInterval write SetInterval default 50;
property Height default 200;
property Width default 320;
property OnClick;
property OnFlame: TNotifyEvent read FOnFlame write SetOnFlame;
property Image: TBitmap read FImage write SetImage;
property BottomRange: DoDvesta read FBottomRange write SetBottomRange;
property SolidFlame: Boolean read FSolidFlame write FSolidFlame;
end;
procedure Register;
implementation
constructor TFlame.Create;
begin
inherited Create(aOwner);
FadeProcess := $FF;
MakePalette;
FEnabled := True;
FInterval := 20;
FWindowHandle := AllocateHWnd(WndProc);
FFadeOut := False;
FFireColor := FireRed;
Height := 200;
Width := 320;
New(FBitmap);
New(FFlameField);
FillChar(FBitmap^, 64000, 0);
FillChar(FFlameField^, 32000, 0);
FImage := TBitmap.Create;
TmpImage := TBitmap.Create;
UpdateTimer;
end;
destructor TFlame.Destroy;
begin
Enabled := False;
DeallocateHWnd(FWindowHandle);
TmpImage.Free;
FImage.Free;
Dispose(FFlameField);
Dispose(FBitmap);
KillPalette;
inherited Destroy;
end;
procedure TFlame.Paint;
var
DC, mDC: hDC;
BitsInfo: pBitmapInfo;
i: Integer;
OldPal: hPalette;
MemB, MemOld:hBitmap;
begin
DC := Canvas.Handle;
GetMem(bitsinfo, SizeOf(TBitmapInfoHeader) + 256 * 2);
with BitsInfo^ do
begin
with bmIHeader do
begin
biSize := 40;
biWidth := 320;
biHeight := 200;
biPlanes := 1;
biBitCount := 8;
biCompression := 0;
biSizeImage := 64000;
biXPelsPerMeter := 0;
biYPelsPerMeter := 0;
biClrUsed := 256;
biClrImportant := 256;
end;
for i := 0 to 127 do
begin
bmIColors[i].RGBBlue := 2 * i;
bmIColors[i].RGBGreen := 0;
bmIColors[i].RGBRed := 2 * i + 1;
bmIColors[i].RGBReserved := 0;
end;
end;
mDC := TmpImage.Canvas.Handle;
MemB := CreateCompatibleBitmap (DC, 320, 200);
MemOld := SelectObject(mDC, MemB);
OldPal := SelectPalette(mDC, FPalette, False);
SetDIBitsToDevice(mDC, 0, 0, Width, Height, 0, 0, 0, 200, FBitmap, BitsInfo^, DIB_Pal_Colors);
{$IFDEF WIN32}
Image.Transparent := True;
Image.TransparentColor := 0; { black }
TmpImage.Canvas.Draw(Width div 2 - Image.Width div 2, Height div 2 - Image.Height div 2,Image);
{$ELSE}
DrawTransparentBitmap(mDC, Width div 2 - Image.Width div 2, Height div 2 - Image.Height div 2,
0, 0, Image.Width,Image.Height);
{$ENDIF}
BitBlt(DC, 0, 0, Width, Height - FBottomRange, mDC, 0, 0, SrcCopy);
DeleteObject(SelectObject(mDC, MemOld));
FreeMem(BitsInfo, SizeOf(TBitmapInfoHeader) + 256 * 2);
SelectPalette(DC, OldPal, False);
end;
procedure TFlame.MakePalette;
var
Pal: PLogPalette;
i: Integer;
procedure SetPalettereg(c, r, g, b: Byte);
begin
case FFireColor of
FireRed:Begin
Pal^.PalPalEntry[c].PeRed:=r shl 2;
Pal^.PalPalEntry[c].PeGreen:=g shl 2;
Pal^.PalPalEntry[c].PeBlue:=b shl 2;
Pal^.PalPalEntry[c].PeFlags:=0;
end;
FireGreen:Begin
Pal^.PalPalEntry[c].PeRed:=g shl 2;
Pal^.PalPalEntry[c].PeGreen:=r shl 2;
Pal^.PalPalEntry[c].PeBlue:=b shl 2;
Pal^.PalPalEntry[c].PeFlags:=0;
end;
FireBlue:Begin
Pal^.PalPalEntry[c].PeRed:=b shl 2;
Pal^.PalPalEntry[c].PeGreen:=g shl 2;
Pal^.PalPalEntry[c].PeBlue:=r shl 2;
Pal^.PalPalEntry[c].PeFlags:=0;
end;
FireDeepPurple:Begin
Pal^.PalPalEntry[c].PeRed:=r shl 2;
Pal^.PalPalEntry[c].PeGreen:=g shl 2;
Pal^.PalPalEntry[c].PeBlue:=r shl 2;
Pal^.PalPalEntry[c].PeFlags:=0;
end;
FireCyan:Begin
Pal^.PalPalEntry[c].PeRed:=b shl 2;
Pal^.PalPalEntry[c].PeGreen:=r shl 2;
Pal^.PalPalEntry[c].PeBlue:=r shl 2;
Pal^.PalPalEntry[c].PeFlags:=0;
end;
FireYellow:Begin
Pal^.PalPalEntry[c].PeRed:=r shl 2;
Pal^.PalPalEntry[c].PeGreen:=r shl 2;
Pal^.PalPalEntry[c].PeBlue:=b shl 2;
Pal^.PalPalEntry[c].PeFlags:=0;
end;
end;
end;
begin
GetMem(Pal, 4 + 256 * 4);
FillChar(Pal^, 4 + 256 * 4, 0);
Pal^.PalVersion := $300;
Pal^.PalNumEntries := 256;
for i:=0 to 63 do SetPaletteReg(i, i, 0, 0);
for i:=0 to 63 do SetPaletteReg(64 + i, 63, i, 0);
for i:=0 to 63 do SetPaletteReg(128 + i, 63, 63, i);
for i:=0 to 63 do SetPaletteReg(192 + i, 63, 63, 63);
FPalette:=CreatePalette(Pal^);
FreeMem(Pal, 4 + 256 * 4);
end;
procedure TFlame.KillPalette;
begin
DeleteObject(FPalette);
end;
function TFlame.GetPalette;
begin
GetPalette:=FPalette;
end;
procedure TFlame.DoFlame;
type
Giant = array[0..$FFFE] of byte;
var
FieldPtr, BitmapPtr: Pointer;
y, x, w, ax, fpt, bpt: Word;
bt: Array[1..2] of Byte;
begin
FieldPtr := FFlameField;
BitmapPtr := FBitmap;
for y := 0 to 97 do
{$IFDEF WIN32}
begin
bpt := 640 * (99 - y);
fpt := 320 * y;
for x := 1 to 160 do
begin
move(Giant(FieldPtr^)[fpt + 159 * 2], w, 2);
ax := w;
move(Giant(FieldPtr^)[fpt + 160 * 2], w, 2);
ax := w + ax;
move(Giant(FieldPtr^)[fpt + 161 * 2], w, 2);
ax := w + ax;
move(Giant(FieldPtr^)[fpt + 320 * 2], w, 2);
ax := w + ax;
ax := ax shr 2;
if ax <> 0 then dec(ax);
move(ax, Giant(FieldPtr^)[fpt], 2);
inc(fpt, 2);
bt[1] := Lo(ax);
bt[2] := bt[1];
Move(bt, ax, 2);
move(ax, Giant(BitmapPtr^)[bpt - 1], 2);
move(ax, Giant(BitmapPtr^)[bpt - 321], 2);
dec(bpt, 2);
end;
{$ELSE}
asm
push ds
les di, BitmapPtr
mov ax,640
mov bx,99
sub bx,y
mul bx
add di,ax
lds si, FieldPtr
mov ax,320
mul y
add si,ax
mov cx,160
@schleifex:
mov ax,[si+159*2]
add ax,[si+160*2]
add ax,[si+161*2]
add ax,[si+320*2]
shr ax,2
cmp ax,0
je @keindec
dec ax
@keindec:
mov [si],ax
add si,2
mov ah,al
mov es:[di-1],ax
mov es:[di-321],ax
sub di,2
loop @schleifex
pop ds
{$ENDIF}
end;
Paint;
end;
procedure TFlame.FlameIt;
begin
if not FFadeOut then
if FSolidFlame then
MakeRandomLine(98+Random(2)) {MIKS}
else
MakeRandomLine(98)
else
MakeDarkLine(98+Random(2)); {MIKS}
DoFlame;
if Assigned(FOnFlame) then FOnFlame(Self);
end;
procedure TFlame.MakeRandomLine;
var
x: Word;
begin
for x := 10 to 149 do
FFlameField^[y, x] := Random(2) * 256;
end;
procedure TFlame.MakeDarkLine;
var
x: Word;
begin
for x := 10 to 149 do
FFlameField^[y, x] := Random(2) + Random(FadeProcess);
if FadeProcess > 0 then dec(FadeProcess)
else
begin
Enabled := False;
FadeOut := False;
FadeProcess := 255;
Paint;
end;
end;
procedure TFlame.SetFlamePixel;
begin
if (x < 0) or (x > 159) or (y < 0) or (y > 199) then Exit;
FFlameField^[y, x] := 256;
end;
procedure TFlame.SetImage;
begin
FImage.Assign(aImage);
Paint;
end;
procedure TFlame.SetBottomRange;
begin
FBottomRange := Value;
Paint;
end;
procedure TFlame.SetFireColor(Value: TFireColor); {MIKS}
begin
FFireColor := Value;
MakePalette;
Paint;
end;
procedure TFlame.SetFadeOut(Value: Boolean);
begin
FFadeOut := Value;
if not FFadeOut then FadeProcess := $FF; { Bypassing Fade bug (UtilMind) }
Paint;
end;
procedure TFlame.WndProc(var Msg: TMessage);
begin
with Msg do
if Msg = WM_TIMER then
try
FlameIt; {!}
except
end
else
Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
end;
procedure TFlame.SetEnabled(Value: Boolean);
begin
if Value <> FEnabled then
begin
FEnabled := Value;
UpdateTimer;
end;
end;
procedure TFlame.SetInterval;
begin
if Value <> FInterval then
begin
FInterval := Value;
UpdateTimer;
end;
end;
procedure TFlame.SetOnFlame(Value: TNotifyEvent);
begin
FOnFlame := Value;
end;
procedure TFlame.UpdateTimer;
begin
KillTimer(FWindowHandle, 1);
if (FInterval <> 0) and FEnabled then
if SetTimer(FWindowHandle, 1, FInterval, nil) = 0 then
raise EOutOfResources.Create('No timers');
end;
{$IFNDEF WIN32}
procedure TFlame.DrawTransparentBitmap(ahdc: HDC;
xStart, yStart, x1,y1,x2,y2: Word);
var
TransparentColor: TColor;
cColor : TColorRef;
bmAndBack,
bmAndObject,
bmAndMem,
bmSave,
bmBackOld,
bmObjectOld,
bmMemOld,
bmSaveOld : HBitmap;
hdcMem,
hdcBack,
hdcObject,
hdcTemp,
hdcSave : HDC;
ptSize : TPoint;
begin
{ set the transparent to black }
TransparentColor := 0;
TransparentColor := TransparentColor or $02000000;
hdcTemp := CreateCompatibleDC (ahdc);
SelectObject (hdcTemp, FImage.Handle); { select the bitmap }
{ convert bitmap dimensions from device to logical points }
ptSize.x := x2-x1;
ptSize.y := y2-y1;
DPToLP (hdcTemp, ptSize, 1); { convert from device logical points }
{ create some DCs to hold temporary data }
hdcBack := CreateCompatibleDC(ahdc);
hdcObject := CreateCompatibleDC(ahdc);
hdcMem := CreateCompatibleDC(ahdc);
hdcSave := CreateCompatibleDC(ahdc);
{ create a bitmap for each DC }
{ monochrome DC }
bmAndBack := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);
bmAndObject := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);
bmAndMem := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);
bmSave := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);
{ each DC must select a bitmap object to store pixel data }
bmBackOld := SelectObject (hdcBack, bmAndBack);
bmObjectOld := SelectObject (hdcObject, bmAndObject);
bmMemOld := SelectObject (hdcMem, bmAndMem);
bmSaveOld := SelectObject (hdcSave, bmSave);
{ set proper mapping mode }
SetMapMode (hdcTemp, GetMapMode (ahdc));
{ save the bitmap sent here, because it will be overwritten }
BitBlt (hdcSave, 0, 0, ptSize.x, ptSize.y, hdcTemp, x1, y1, SRCCOPY);
{ set the background color of the source DC to the color.
contained in the parts of the bitmap that should be transparent }
cColor := SetBkColor (hdcTemp, TransparentColor);
{ create the object mask for the bitmap by performing a BitBlt()
from the source bitmap to a monochrome bitmap }
BitBlt (hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, x1, y1, SRCCOPY);
{ set the background color of the source DC back to the original color }
SetBkColor (hdcTemp, cColor);
{ create the inverse of the object mask }
BitBlt (hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY);
{ copy the background of the main DC to the destination }
BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, ahdc, xStart, yStart, SRCCOPY);
{ mask out the places where the bitmap will be placed }
BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);
{ mask out the transparent colored pixels on the bitmap }
BitBlt (hdcTemp, x1, y1, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);
{ XOR the bitmap with the background on the destination DC }
BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, x1, y1, SRCPAINT);
{ copy the destination to the screen }
BitBlt (ahdc, xStart, yStart, ptSize.x, ptSize.y, hdcMem, 0, 0, SRCCOPY);
{ place the original bitmap back into the bitmap sent here }
BitBlt (hdcTemp, x1, y1, ptSize.x, ptSize.y, hdcSave, 0, 0, SRCCOPY);
{ delete the memory bitmaps }
DeleteObject (SelectObject (hdcBack, bmBackOld));
DeleteObject (SelectObject (hdcObject, bmObjectOld));
DeleteObject (SelectObject (hdcMem, bmMemOld));
DeleteObject (SelectObject (hdcSave, bmSaveOld));
{ delete the memory DCs }
DeleteDC (hdcMem);
DeleteDC (hdcBack);
DeleteDC (hdcObject);
DeleteDC (hdcSave);
DeleteDC (hdcTemp);
end;
{$ENDIF}
procedure Register;
begin
RegisterComponents('UtilMind', [TFlame]);
end;
end.
|
Это сообщение отредактировал(а) s-mike - 23.1.2005, 12:51 |
Интересные еффекты, Где найти ? 
Загрузка ...
