ScreenMate

Многие из вас знакомы с этим термином. Так характеризуют программы, которые выводят на экран спрайтового персонажа, не создавая при этом окна. Я очень давно искал данный пример в сети, и теперь решил вас порадовать. Программа состоит из нескольких узлов, кои будут приведены ниже...
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);
Source: http://delphiworld.narod.ru
ID: 04645
Category:Развлечения