ScreenMate
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);