Playing card flip animation

问题

Do you know of any free components/libraries, which allow to achieve a 3D flip effect?

Demo here: snorkl.tv

回答1:

Something like this might do the similar effect (just another attempt to show how this could be done, also not so precise, but it's just for fun since you've asked for a library or component). The principle is based on a rectnagle that is being resized and centered in the paint box where the card is being rendered with the StretchDraw function:

Unit1.pas

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, PNGImage;

type
  TCardSide = (csBack, csFront);
  TForm1 = class(TForm)
    Timer1: TTimer;
    Timer2: TTimer;
    PaintBox1: TPaintBox;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);
    procedure PaintBox1Click(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
  private
    FCardRect: TRect;
    FCardSide: TCardSide;
    FCardBack: TPNGImage;
    FCardFront: TPNGImage;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FCardSide := csBack;
  FCardRect := PaintBox1.ClientRect;
  FCardBack := TPNGImage.Create;
  FCardBack.LoadFromFile('tps2N.png');
  FCardFront := TPNGImage.Create;
  FCardFront.LoadFromFile('Ey3cv.png');
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FCardBack.Free;
  FCardFront.Free;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if FCardRect.Right - FCardRect.Left > 0 then
  begin
    FCardRect.Left := FCardRect.Left + 3;
    FCardRect.Right := FCardRect.Right - 3;
    PaintBox1.Invalidate;
  end
  else
  begin
    Timer1.Enabled := False;
    case FCardSide of
      csBack: FCardSide := csFront;
      csFront: FCardSide := csBack;
    end;
    Timer2.Enabled := True;
  end;
end;

procedure TForm1.Timer2Timer(Sender: TObject);
begin
  if FCardRect.Right - FCardRect.Left < PaintBox1.ClientWidth then
  begin
    FCardRect.Left := FCardRect.Left - 3;
    FCardRect.Right := FCardRect.Right + 3;
    PaintBox1.Invalidate;
  end
  else
    Timer2.Enabled := False;
end;

procedure TForm1.PaintBox1Click(Sender: TObject);
begin
  Timer1.Enabled := False;
  Timer2.Enabled := False;
  FCardRect := PaintBox1.ClientRect;
  Timer1.Enabled := True;
  PaintBox1.Invalidate;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  case FCardSide of
    csBack: PaintBox1.Canvas.StretchDraw(FCardRect, FCardBack);
    csFront: PaintBox1.Canvas.StretchDraw(FCardRect, FCardFront);
  end;
end;

end.

Unit1.dfm

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 203
  ClientWidth = 173
  Color = clBtnFace
  DoubleBuffered = True
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object PaintBox1: TPaintBox
    Left = 48
    Top = 40
    Width = 77
    Height = 121
    OnClick = PaintBox1Click
    OnPaint = PaintBox1Paint
  end
  object Timer1: TTimer
    Enabled = False
    Interval = 10
    OnTimer = Timer1Timer
    Left = 32
    Top = 88
  end
  object Timer2: TTimer
    Enabled = False
    Interval = 10
    OnTimer = Timer2Timer
    Left = 88
    Top = 88
  end
end

Cards

回答2:

Here's an attempt using SetWorldTransform:

type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Button1: TButton;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    FFrontBmp, FBackBmp: TBitmap;
    FBmps: array [Boolean] of TBitmap;
    FXForm: TXForm;
    FStep: Integer;
  end;

var
  Form1: TForm1;

implementation

uses
  Math;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FFrontBmp := TBitmap.Create;
  FFrontBmp.LoadFromFile(ExtractFilePath(Application.ExeName) + '53.bmp');
  FBackBmp := TBitmap.Create;
  FBackBmp.LoadFromFile(ExtractFilePath(Application.ExeName) + 'b1fv.bmp');
  FBmps[True] := FFrontBmp;
  FBmps[False] := FBackBmp;

  FXForm.eM11 := 1;
  FXForm.eM12 := 0;
  FXForm.eM21 := 0;
  FXForm.eM22 := 1;
  FXForm.eDx := 0;
  FXForm.eDy := 0;

  Timer1.Enabled := False;
  Timer1.Interval := 30;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FFrontBmp.Free;
  FBackBmp.Free;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  SetGraphicsMode(PaintBox1.Canvas.Handle, GM_ADVANCED);
  SetWorldTransform(PaintBox1.Canvas.Handle, FXForm);
  PaintBox1.Canvas.Draw(0, 0, FBmps[FStep < 20]);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  Bmp: TBitmap;
  Sign: Integer;
begin
  Inc(FStep);

  Sign := math.Sign(FStep - 20);
  FXForm.eM11 := FXForm.eM11 + 0.05 * Sign;
  FXForm.eM21 := FXForm.eM21 - 0.005 * Sign;
  FXForm.eDx := FXForm.eDx - 1 * Sign;
  if FStep = 39 then begin
    Timer1.Enabled := False;
    PaintBox1.Refresh;
  end else
    PaintBox1.Invalidate;

  if not Timer1.Enabled then begin
    Bmp := FBmps[True];
    FBmps[True] := FBmps[False];
    FBmps[False] := Bmp;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Timer1.Enabled := True;
  FStep := 0;
end;

I'm not sure if this stood a chance of turning out to be anything beautiful in case I had some maths capability, but here's currently how it looks:

The images used:  

 

来源：https://stackoverflow.com/questions/10585068/playing-card-flip-animation