ScreenMate

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

{*******************************************************}

  { }

  { 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, , FImageWidth, FImageHeight);

 end;

end;

type

 TParentControl = class(TWinControl);

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...