Многие из вас знакомы с этим термином. Так характеризуют программы, которые выводят на экран спрайтового персонажа, не создавая при этом окна. Я очень давно искал данный пример в сети, и теперь решил вас порадовать. Программа состоит из нескольких узлов, кои будут приведены ниже...

p.s К сожалению вам надо позаботиться о кадрах анимации этого персонажа самим т.к рисунки я послать немогу...

{*******************************************************}
{ }
{ Delphi VCL Extensions (RX) }
{ }
{ Copyright (c) 1995, 1996 AO ROSNO }
{ Copyright (c) 1997, 1998 Master-Bank }
{ }
{*******************************************************}

unit Animate;

interface

{$I RX.INC}

uses Messages, {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, Menus, ExtCtrls;

type
TGlyphOrientation = (goHorizontal, goVertical);

{ TRxImageControl }

TRxImageControl = class(TGraphicControl)
private
FDrawing: Boolean;
protected
FGraphic: TGraphic;
function DoPaletteChange: Boolean;
procedure DoPaintImage; virtual; abstract;
procedure PaintDesignRect;
procedure PaintImage;
procedure PictureChanged;
public
constructor Create(AOwner: TComponent); override;
end;

{ TAnimatedImage }

TAnimatedImage = class(TRxImageControl)
private
{ Private declarations }
FActive: Boolean;
FAutoSize: Boolean;
FGlyph: TBitmap;
FImageWidth: Integer;
FImageHeight: Integer;
FInactiveGlyph: Integer;
FOrientation: TGlyphOrientation;
FTimer: TTimer;
FNumGlyphs: Integer;
FGlyphNum: Integer;
FStretch: Boolean;
FTransparentColor: TColor;
FOpaque: Boolean;
FTimerRepaint: Boolean;
FOnFrameChanged: TNotifyEvent;
FOnStart: TNotifyEvent;
FOnStop: TNotifyEvent;
procedure DefineBitmapSize;
procedure ResetImageBounds;
procedure AdjustBounds;
function GetInterval: Cardinal;
procedure SetAutoSize(Value: Boolean);
procedure SetInterval(Value: Cardinal);
procedure SetActive(Value: Boolean);
procedure SetOrientation(Value: TGlyphOrientation);
procedure SetGlyph(Value: TBitmap);
procedure SetGlyphNum(Value: Integer);
procedure SetInactiveGlyph(Value: Integer);
procedure SetNumGlyphs(Value: Integer);
procedure SetStretch(Value: Boolean);
procedure SetTransparentColor(Value: TColor);
procedure SetOpaque(Value: Boolean);
procedure ImageChanged(Sender: TObject);
procedure UpdateInactive;
procedure TimerExpired(Sender: TObject);
function TransparentStored: Boolean;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
protected
{ Protected declarations }
function GetPalette: HPALETTE; override;
procedure Loaded; override;
procedure Paint; override;
procedure DoPaintImage; override;
procedure FrameChanged; dynamic;
procedure Start; dynamic;
procedure Stop; dynamic;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure DoPaintImageOn(Mycanvas:Tcanvas; x, y: integer); virtual;
published
{ Published declarations }
property Active: Boolean read FActive write SetActive default False;
property Align;
property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
property Orientation: TGlyphOrientation read FOrientation write SetOrientation
default goHorizontal;
property Glyph: TBitmap read FGlyph write SetGlyph;
property GlyphNum: Integer read FGlyphNum write SetGlyphNum default 0;
property Interval: Cardinal read GetInterval write SetInterval default 100;
property NumGlyphs: Integer read FNumGlyphs write SetNumGlyphs default 1;
property InactiveGlyph: Integer read FInactiveGlyph write SetInactiveGlyph default -1;
property TransparentColor: TColor read FTransparentColor write SetTransparentColor
stored TransparentStored;
property Opaque: Boolean read FOpaque write SetOpaque default False;
property Color;
property Cursor;
property DragCursor;
property DragMode;
property ParentColor default True;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Stretch: Boolean read FStretch write SetStretch default True;
property Visible;
property OnClick;
property OnDblClick;
property OnMouseMove;
property OnMouseDown;
property OnMouseUp;
property OnDragOver;
property OnDragDrop;
property OnEndDrag;
{$IFDEF WIN32}
property OnStartDrag;
{$ENDIF}
property OnFrameChanged: TNotifyEvent read FOnFrameChanged write FOnFrameChanged;
property OnStart: TNotifyEvent read FOnStart write FOnStart;
property OnStop: TNotifyEvent read FOnStop write FOnStop;
end;

implementation

uses RxConst, VCLUtils;

{ TRxImageControl }

constructor TRxImageControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csClickEvents, csCaptureMouse, csOpaque,
{$IFDEF WIN32} csReplicatable, {$ENDIF} csDoubleClicks];
Height := 105;
Width := 105;
ParentColor := True;
end;

procedure TRxImageControl.PaintImage;
var
Save: Boolean;
begin
Save := FDrawing;
FDrawing := True;
try
DoPaintImage;
finally
FDrawing := Save;
end;
end;

procedure TRxImageControl.PaintDesignRect;
begin
if csDesigning in ComponentState then
with Canvas do begin
Pen.Style := psDash;
Brush.Style := bsClear;
Rectangle(0, 0, Width, Height);
end;
end;

function TRxImageControl.DoPaletteChange: Boolean;
var
ParentForm: TCustomForm;
Tmp: TGraphic;
begin
Result := False;
Tmp := FGraphic;
if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil)
{$IFDEF RX_D3} and (Tmp.PaletteModified) {$ENDIF} then
begin
if (GetPalette <> 0) then begin
ParentForm := GetParentForm(Self);
if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
begin
if FDrawing then
ParentForm.Perform(WM_QUERYNEWPALETTE, 0, 0)
else
PostMessage(ParentForm.Handle, WM_QUERYNEWPALETTE, 0, 0);
Result := True;
{$IFDEF RX_D3}
Tmp.PaletteModified := False;
{$ENDIF}
end;
end
{$IFDEF RX_D3}
else begin
Tmp.PaletteModified := False;
end;
{$ENDIF}
end;
end;

procedure TRxImageControl.PictureChanged;
begin
if (FGraphic <> nil) then
if DoPaletteChange and FDrawing then Update;
if not FDrawing then Invalidate;
end;

{ TAnimatedImage }

constructor TAnimatedImage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FTimer := TTimer.Create(Self);
Interval := 100;
FGlyph := TBitmap.Create;
FGraphic := FGlyph;
FGlyph.OnChange := ImageChanged;
FGlyphNum := 0;
FNumGlyphs := 1;
FInactiveGlyph := -1;
FTransparentColor := clNone;
FOrientation := goHorizontal;
FAutoSize := True;
FStretch := True;
Width := 32;
Height := 32;
end;

destructor TAnimatedImage.Destroy;
begin
FOnFrameChanged := nil;
FOnStart := nil;
FOnStop := nil;
FGlyph.OnChange := nil;
Active := False;
FGlyph.Free;
inherited Destroy;
end;

procedure TAnimatedImage.Loaded;
begin
inherited Loaded;
ResetImageBounds;
UpdateInactive;
end;

function TAnimatedImage.GetPalette: HPALETTE;
begin
Result := 0;
if not FGlyph.Empty then Result := FGlyph.Palette;
end;

procedure TAnimatedImage.ImageChanged(Sender: TObject);
begin
FTransparentColor := FGlyph.TransparentColor and not PaletteMask;
DefineBitmapSize;
AdjustBounds;
PictureChanged;
end;

procedure TAnimatedImage.UpdateInactive;
begin
if (not Active) and (FInactiveGlyph >= 0) and
(FInactiveGlyph < FNumGlyphs) and (FGlyphNum <> FInactiveGlyph) then
begin
FGlyphNum := FInactiveGlyph;
end;
end;

function TAnimatedImage.TransparentStored: Boolean;
begin
Result := (FGlyph.Empty and (FTransparentColor <> clNone)) or
((FGlyph.TransparentColor and not PaletteMask) <>
FTransparentColor);
end;

procedure TAnimatedImage.SetOpaque(Value: Boolean);
begin
if Value <> FOpaque then begin
FOpaque := Value;
PictureChanged;
end;
end;

procedure TAnimatedImage.SetTransparentColor(Value: TColor);
begin
if Value <> TransparentColor then begin
FTransparentColor := Value;
PictureChanged;
end;
end;

procedure TAnimatedImage.SetOrientation(Value: TGlyphOrientation);
begin
if FOrientation <> Value then begin
FOrientation := Value;
DefineBitmapSize;
AdjustBounds;
Invalidate;
end;
end;

procedure TAnimatedImage.SetGlyph(Value: TBitmap);
begin
FGlyph.Assign(Value);
end;

procedure TAnimatedImage.SetStretch(Value: Boolean);
begin
if Value <> FStretch then begin
FStretch := Value;
PictureChanged;
if Active then Repaint;
end;
end;

procedure TAnimatedImage.SetGlyphNum(Value: Integer);
begin
if Value <> FGlyphNum then begin
if (Value < FNumGlyphs) and (Value >= 0) then begin
FGlyphNum := Value;
UpdateInactive;
FrameChanged;
PictureChanged;
end;
end;
end;

procedure TAnimatedImage.SetInactiveGlyph(Value: Integer);
begin
if Value < 0 then Value := -1;
if Value <> FInactiveGlyph then begin
if (Value < FNumGlyphs) or (csLoading in ComponentState) then begin
FInactiveGlyph := Value;
UpdateInactive;
FrameChanged;
PictureChanged;
end;
end;
end;

procedure TAnimatedImage.SetNumGlyphs(Value: Integer);
begin
FNumGlyphs := Value;
if FInactiveGlyph >= FNumGlyphs then begin
FInactiveGlyph := -1;
FGlyphNum := 0;
end
else UpdateInactive;
FrameChanged;
ResetImageBounds;
AdjustBounds;
PictureChanged;
end;

procedure TAnimatedImage.DefineBitmapSize;
begin
FNumGlyphs := 1;
FGlyphNum := 0;
FImageWidth := 0;
FImageHeight := 0;
if (FOrientation = goHorizontal) and (FGlyph.Height > 0) and
(FGlyph.Width mod FGlyph.Height = 0) then
FNumGlyphs := FGlyph.Width div FGlyph.Height
else if (FOrientation = goVertical) and (FGlyph.Width > 0) and
(FGlyph.Height mod FGlyph.Width = 0) then
FNumGlyphs := FGlyph.Height div FGlyph.Width;
ResetImageBounds;
end;

procedure TAnimatedImage.ResetImageBounds;
begin
if FNumGlyphs < 1 then FNumGlyphs := 1;
if FOrientation = goHorizontal then begin
FImageHeight := FGlyph.Height;
FImageWidth := FGlyph.Width div FNumGlyphs;
end
else {if Orientation = goVertical then} begin
FImageWidth := FGlyph.Width;
FImageHeight := FGlyph.Height div FNumGlyphs;
end;
end;

procedure TAnimatedImage.AdjustBounds;
begin
if not (csReading in ComponentState) then begin
if FAutoSize and (FImageWidth > 0) and (FImageHeight > 0) then
SetBounds(Left, Top, FImageWidth, FImageHeight);
end;
end;

type
TParentControl = class(TWinControl);

procedure TAnimatedImage.DoPaintImageOn(Mycanvas:Tcanvas; x, y: integer);
var
BmpIndex: Integer;
SrcRect: TRect;
begin
if (not Active) and (FInactiveGlyph >= 0) and
(FInactiveGlyph < FNumGlyphs) then BmpIndex := FInactiveGlyph
else BmpIndex := FGlyphNum;
{ copy image from parent and back-level controls }
if (FImageWidth > 0) and (FImageHeight> 0) then
begin
if Orientation = goHorizontal then
SrcRect := Bounds(BmpIndex * FImageWidth, 0, FImageWidth, FImageHeight)
else {if Orientation = goVertical then}
SrcRect := Bounds(0, BmpIndex * FImageHeight, FImageWidth, FImageHeight);
if FStretch then
StretchBitmapRectTransparent(MyCanvas, x, y, Width, Height, SrcRect,
FGlyph, FTransparentColor)
else
DrawBitmapRectTransparent(MyCanvas, x, y, SrcRect, FGlyph,
FTransparentColor);
end;
end;

procedure TAnimatedImage.DoPaintImage;
var
TmpImage: TBitmap;
BmpIndex: Integer;
SrcRect: TRect;
begin
if (not Active) and (FInactiveGlyph >= 0) and
(FInactiveGlyph < FNumGlyphs) then BmpIndex := FInactiveGlyph
else BmpIndex := FGlyphNum;
TmpImage := TBitmap.Create;
try
with TmpImage do begin
Width := ClientWidth;
Height := ClientHeight;
if (not FOpaque) and (Self.Parent <> nil) then
Canvas.Brush.Color := TParentControl(Self.Parent).Color
else Canvas.Brush.Color := Self.Color;
Canvas.FillRect(Bounds(0, 0, Width, Height));
{ copy image from parent and back-level controls }
if not FOpaque then CopyParentImage(Self, Canvas);
if (FImageWidth > 0) and (FImageHeight> 0) then begin
if Orientation = goHorizontal then
SrcRect := Bounds(BmpIndex * FImageWidth, 0, FImageWidth, FImageHeight)
else {if Orientation = goVertical then}
SrcRect := Bounds(0, BmpIndex * FImageHeight, FImageWidth, FImageHeight);
if FStretch then
StretchBitmapRectTransparent(Canvas, 0, 0, Width, Height, SrcRect,
FGlyph, FTransparentColor)
else
DrawBitmapRectTransparent(Canvas, 0, 0, SrcRect, FGlyph,
FTransparentColor);
end;
end;
Canvas.Draw(ClientRect.Left, ClientRect.Top, TmpImage);
finally
TmpImage.Free;
end;
end;

procedure TAnimatedImage.Paint;
begin
PaintImage;
PaintDesignRect;
end;

procedure TAnimatedImage.TimerExpired(Sender: TObject);
begin
if Visible and (FNumGlyphs > 1) then begin
if FGlyphNum < FNumGlyphs - 1 then Inc(FGlyphNum)
else FGlyphNum := 0;
if (FGlyphNum = FInactiveGlyph) and (FNumGlyphs > 1) then begin
if FGlyphNum < FNumGlyphs - 1 then Inc(FGlyphNum)
else FGlyphNum := 0;
end;
FTimerRepaint := True;
try
FrameChanged;
Repaint;
finally
FTimerRepaint := False;
end;
end;
end;

procedure TAnimatedImage.FrameChanged;
begin
if Assigned(FOnFrameChanged) then FOnFrameChanged(Self);
end;

procedure TAnimatedImage.Stop;
begin
if not (csReading in ComponentState) then
if Assigned(FOnStop) then FOnStop(Self);
end;

procedure TAnimatedImage.Start;
begin
if not (csReading in ComponentState) then
if Assigned(FOnStart) then FOnStart(Self);
end;

procedure TAnimatedImage.SetAutoSize(Value: Boolean);
begin
if Value <> FAutoSize then begin
FAutoSize := Value;
AdjustBounds;
PictureChanged;
end;
end;

procedure TAnimatedImage.SetInterval(Value: Cardinal);
begin
FTimer.Interval := Value;
end;

function TAnimatedImage.GetInterval: Cardinal;
begin
Result := FTimer.Interval;
end;

procedure TAnimatedImage.SetActive(Value: Boolean);
begin
if FActive <> Value then begin
if Value then begin
FTimer.OnTimer := TimerExpired;
FTimer.Enabled := True;
FActive := FTimer.Enabled;
Start;
end
else begin
FTimer.Enabled := False;
FTimer.OnTimer := nil;
FActive := False;
UpdateInactive;
FrameChanged;
Stop;
PictureChanged;
end;
end;
end;

procedure TAnimatedImage.WMSize(var Message: TWMSize);
begin
inherited;
AdjustBounds;
end;

end.

---

 

{
Desktop Sprite Demo 1.51

By Nelson Chu 1998

Email : eg_cshaa@stu.ust.hk
Wpage : http://home.ust.hk/~eg_cshaa

Description:
It basically shows how to make sprite animation on the Win95 desktop
like the toy programs "ScreenMate". The animation is done by copying
rectangles directly to the desktop - not by creating a transparent
window. With WinAPI functions like getforegroundwindow() or GetwindowRect(),
you can make your character sitting on the foreground window.

New in v1.51:
1. Update the background if changed
2. Avoid painting on the foreground window
3. Clear traces when terminates
4. Fixed bug of not releasing desktop DC in v1.5

To-do list:
1. Mouse draggable
2. Popup menu
3. Make it a component for easy production of programs like "ScreenMate"

Compilation Note:
Requires RXlib 2.4 or above. Please install it first.

If you improve on it, did one of the items in the To-do list, or make
something nice out of this demo, please send me a copy too! ;)
}

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Animate, StdCtrls, ExtCtrls;

type
TForm1 = class(TForm)
AnimatedImage1: TAnimatedImage;
Label1: TLabel;
Label2: TLabel;
Bevel1: TBevel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure AnimatedImage1FrameChanged(Sender: TObject);
private
{ Private declarations }
nx, ny, ox, oy, dx, dy : integer; // new, old (x,y) and deviation
sp_w : integer; // sprite width
sp_h : integer; // sprite height
sc : TCanvas; // screen canvas
working, savedback : TBitmap;
TopTitle : PChar; // for tracking which foreground window
OldTopWindow : Hwnd; // for tracking if foreground window changed
procedure SaveBackground(Sender:Tobject);
procedure MoveSprite(Sender:Tobject);
procedure PaintSprite(Sender: TObject);
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.savebackground(Sender:Tobject);
begin
sc:=TCanvas.Create;
try
sc.Handle:=GetDC(0);
savedback.canvas.CopyRect( rect(0,0,sp_w, sp_h), sc,
rect(nx, ny, nx+sp_w, ny+sp_h));
ReleaseDC(0, sc.handle);
finally
sc.free;
end;
end;

function XslateRect(R:Trect; x,y:integer):Trect;
begin
with R do Result:=Rect(left-x, top-y, right-x, bottom-y);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
sp_w:=animatedimage1.Width;
sp_h:=animatedimage1.Height;

try working:=Tbitmap.Create; except working.free; end;
try savedback:=Tbitmap.Create; except savedback.free; end;
try TopTitle:=strAlloc(20); except StrDispose(TopTitle); end;

savedback.width:=sp_w;
savedback.height:=sp_h;
working.width:=sp_w;
working.height:=sp_h;

nx:=(screen.Width-sp_w) div 2;
ny:=(screen.Height-sp_h) div 2;
ox:=nx; oy:=ny;
savebackground(Self);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
// refresh the whole screen at the end
RedrawWindow(0, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN);
working.free;
savedback.free;
StrDispose(TopTitle);
end;

procedure TForm1.AnimatedImage1FrameChanged(Sender: TObject);
begin
PaintSprite(self);
MoveSprite(self);
end;

procedure TForm1.PaintSprite(Sender: TObject);
var TopRgn, newRgn, oldRgn, TempRgn : Hrgn;
TopRect, newRect, oldRect, OrgRect, TempRect : TRect;
TopWindow : Hwnd;
begin
newRect:=Rect(nx, ny, nx+sp_w, ny+sp_h);
oldRect:=Rect(ox, oy, ox+sp_w, oy+sp_h);
orgRect:=Rect(0, 0, sp_w, sp_h);

TopWindow:=GetForegroundWindow;
GetwindowRect(TopWindow,TopRect);
GetwindowText(TopWindow, TopTitle, 19);
TopRgn:=CreateRectRgnIndirect(TopRect);
label1.caption:='Foreground Window: '+TopTitle;

newRgn:=CreateRectRgnIndirect(newRect);
oldRgn:=CreateRectRgnIndirect(oldRect);
TempRgn:=CreateRectRgnIndirect(oldRect);

try
sc:=TCanvas.Create;
try
sc.handle:=getDC(0);

// copy the new background to 'working'
working.canvas.CopyRect(orgRect, sc, newRect);
// recover the invalid background just copied
CombineRgn(TempRgn, newRgn, oldRgn, RGN_AND);
getRgnBox(TempRgn, TempRect);
working.canvas.CopyRect(XslateRect(TempRect, nx, ny), savedback.canvas,
XslateRect(TempRect, ox, oy) );

// grep the new background area
savedback.canvas.CopyRect(orgRect, working.canvas, OrgRect);
animatedimage1.DoPaintImageOn(working.canvas, 0, 0);
// the following is for avoiding painting on the active form
if IntersectRect(TempRect, TopRect, NewRect) and
(TopTitle<>'Program Manager') // not when the wallpaper, etc is clicked
then working.canvas.CopyRect(XslateRect(TempRect, nx, ny), sc, TempRect);
// put the sprite on the screen
sc.CopyRect(newRect, working.canvas, orgRect);

ReleaseDC(0, sc.handle);
finally
sc.free;
end;

// erase the trace by updating the region
CombineRgn(TempRgn, oldRgn, newRgn, RGN_DIFF);
if TopTitle<>'Program Manager' then
CombineRgn(TempRgn, TempRgn, TopRgn, RGN_DIFF);
RedrawWindow(0, nil, TempRgn, RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN);

if oldTopwindow<>Topwindow then // foreground window changes
RedrawWindow(0, nil, OldRgn, RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN);

finally
DeleteObject(TopRgn);
DeleteObject(TempRgn);
DeleteObject(NewRgn);
DeleteObject(OldRgn);
end;

OldTopWindow:=TopWindow;
end;

procedure TForm1.MoveSprite(Sender:Tobject);
// this is where you define your character's movement. You can use
// GetCursorPos() to play with the mouse pointer.
var pt:Tpoint;
begin
getCursorPos(pt);
if ny<pt.y then dy:=1 else
if ny>pt.y then dy:=-1;
dx:=4;

ox:=nx; oy:=ny;
nx:=nx+dx; ny:=ny+dy;

// wrap the sprite
if nx<-sp_w then
begin nx:=screen.Width-sp_w;
savebackground(Self); end;
if nx>screen.width then
begin nx:=0;
savebackground(Self); end;
end;

end.