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

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

{*******************************************************}
 { }
 { 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);

Получить ссылку на материал