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

Другое по теме:

Категории

Статьи

Советы

Copyright © 2022 - All Rights Reserved - www.delphirus.com