Быстрая анимация посредством Delphi Опции

[Gothic_Snake]

Существует поверье, что написание анимации посредством Canvas в Delphi очень неблагодарное дело, мол тормоза, мерцание... Кул программеры сразу начинают изучать OpenGL/DX
На это есесно уходит многа времени...
Хочу привести пару примеров работы в Delphi с TCanvas+GDI
Ниже приведен пример заставки с часиками

Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, Buttons,commctrl;
var
  Window:HWND;
  DC:Hdc;
  DCCanv:TCanvas;
const
  SnowCount=2000;
type
  TSnow=class
    dc:Integer;
    col:Tcolor;
    cnv:Tcanvas;
    X,Y:Integer;
    Dx:Integer;
    dy:Integer;
    widht,Height:Integer;
    Constructor Create;
    Procedure Draw;
  end;
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
    f:Boolean;
    Snows:array of TSnow;
    col:Tcolor;
    dc:Integer;
    buf:TBitmap;
    x:Integer;
    dx:integer;
    Function Rct:Trect;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  i:integer;
  fx:byte;
begin
  x:=5;
  dx:=5;
  dc:=1;
  ShowCursor(false);
  buf:=TBitmap.Create;
  SetLength(snows,snowcount);
  for i:=0 to snowcount -1 do
  begin
    Snows[i]:=TSnow.Create;
    with Snows[i] do
    begin
      Dx:=random(3)-random(3);
      dy:=random(3)+1;
      widht:=Screen.Width;
      Height:=Screen.Height;
      X:=random(Screen.Width);
      Y:=random(Screen.Height);
      cnv:=buf.Canvas;
      fx:=random(256);
      col:=rgb(fx,fx,fx);
    end;
  end;
  Left:=0;
  Top:=0;
  Width:=Screen.Width;
  Height:=Screen.Height;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  buf.Width:=PaintBox1.Width;
  buf.Height:=PaintBox1.Height;
end;

function TForm1.Rct: Trect;
begin
  Result:=PaintBox1.ClientRect;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  i:integer;
begin
  col:=rgb(GetrValue(col)+dc,GetgValue(col)+dc,GetBValue(col)+dc);
  if (col=$00FFFFff)or(col=0) then dc:=-dc;
  with buf.Canvas do
  begin
    Brush.Color:=clBlack;
    FillRect(Rct);
    Font.Color:=COL;
    Font.Name:='Courier New';
    font.Size:=70;
    x:=x+dx;
    if (x>460)or(x=5) then dx:=-dx;
    TextOut(x,600,'© By Snake');
    font.Size:=50;
    TextOut(x+120,700,timetostr(now));
  end;
  for i:=0 to SnowCount-1 do
    Snows[i].Draw;
  PaintBox1.Canvas.CopyRect(rct,buf.Canvas,rct);
end;

constructor TSnow.Create;
begin
  dc:=1;
end;

procedure TSnow.Draw;
var
  fx:byte;
begin
  col:=rgb(GetrValue(col)+dc,GetgValue(col)+dc,GetBValue(col)+dc);
  if (col=$00ffffff)or(col=0) then dc:=-dc;
  x:=x+dx+random(3)-random(3);
  y:=y+dy;
  if (x>=widht)or(x<0)or(y>=Height) then
  begin
    dx:=random(3)-random(3);
    dy:=random(3)+1;
    y:=0;
    x:=random(screen.Width);
    fx:=random(256);
    col:=rgb(fx,fx,fx);
  end;
  cnv.Pixels[x,y]:=col;
end;

procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if not f then
  begin
    f:=true;
    exit;
  end;

end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
  close;
end;

procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  close;
end;

end.

frm

object Form1: TForm1
  Left = 215
  Top = 132
  BorderStyle = bsNone
  Caption = 'Form1'
  ClientHeight = 447
  ClientWidth = 644
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  KeyPreview = True
  OldCreateOrder = False
  Position = poDefault
  Visible = True
  OnCreate = FormCreate
  OnKeyPress = FormKeyPress
  OnResize = FormResize
  PixelsPerInch = 96
  TextHeight = 13
  object PaintBox1: TPaintBox
    Left = 0
    Top = 0
    Width = 644
    Height = 447
    Align = alClient
    OnMouseDown = PaintBox1MouseDown
  end
  object Timer1: TTimer
    Interval = 1
    OnTimer = Timer1Timer
    Left = 8
    Top = 8
  end
end

Сообщение отредактировано: GoodWind - 22.12.2005 22:11

[hardcase]

Пардон, DD. Извините - очепятался.
DD использует - c хедерами даже модуль поставляется DirectDraw.
Там кое-какие интефейсы прописываются...

[Gothic_Snake]

Пардон, DD. Извините - очепятался.
DD использует - c хедерами даже модуль поставляется DirectDraw.
Там кое-какие интефейсы прописываются...

Бывает... А есть у тя эти хедеры? Скинь если не трудно..

[hardcase]

Бывает... А есть у тя эти хедеры? Скинь если не трудно..

Вот джедайские хедеры с сэмплами.

Кончно, реализация классов не очень удобна.
Я в своих пограммах писал собстверрые классы-адаптеры для уже объявленных. Просто модель классов, начисто скопирована из gdiplus.h, написанного на C++

Но в целом библиотека гораздо удобнее чем обычные API.

Сообщение отредактировано: hardcase - 11.01.2006 16:16