图片滑动效果。 BitBlt 闪闪发光

Question

我想创建一个幻灯片效果：一张位图从右到左绘制在表单的 canvas 上。为此，我使用 BitBlt。

我在计时器（20 毫秒）中调用此函数：

var ViewPort: TRect;
ViewPort.Left   := 0;
ViewPort.Top    := 0;
ViewPort.Width  := 1400;
ViewPort.Height := 900;

x: integer := spnStep.Value;  //SpinBox.Value = 10

procedure TfrmTester.Slide(BMP: TBitmap; ViewPort: TRect);
begin
 Inc(x, spnStep.Value);

 if x >= ViewPort.Width then
  begin
   x:= ViewPort.Width;
   Timer.Enabled:= FALSE;
  end;

 BitBlt(frmTester.Canvas.Handle,
        ViewPort.Width-x, 0,    //  X, Y
        x, ViewPort.Height,     // cX, cY
      BMP.Canvas.Handle, 0, 0, SRCCOPY);
end;

然而，图像进展并不顺利。它有某种闪烁，但不是我们在 VCL 中知道的那种闪烁。很难描述它。就像图像向前移动两个像素，然后向后移动一个像素。

如何使图像移动流畅？难道真的是显示器刷新率引起的？

更新：我不知道为什么，但它是由定时器引起的。如果我在 'for' 循环中调用 Slide() 则动画很流畅。我知道计时器的精度约为 15 毫秒，但我仍然不明白为什么它会使图像闪烁。如果我在循环中添加一个 sleed(1)，微光效果会再次出现，而且会更糟。这张图真的好像画了两遍

Answer 1

您根本不应该从其 OnPaint 事件之外在表单的 Canvas 上绘图。所有绘图都应仅在 OnPaint 事件中。让您的计时器将所需信息保存到表单可以访问的变量中，然后 Invalidate() 表单，并让它的 OnPaint 事件使用最新保存的信息绘制图像。

或者，只需在 TImage 控件中显示您的 BMP，然后让计时器设置该控件的 Left/Top/Width/ Height 个需要的属性。让 TImage 为您处理图像的绘制。

Answer 2

首先，您应该只在表单的 OnPaint 处理程序中绘制表单。我不知道你是否这样做，但你应该这样做。

其次，您不能真正依赖连续 WM_TIMER 消息之间的时间距离非常精确甚至恒定。所以每次画画的时候最好检查一下实际时间。例如，您可以使用学校物理中已知的公式 Position = Original Position + Velocity × Time。

此外，为了避免闪烁，您可能应该处理 WM_ERASEBKGND。

把这些放在一起，

unit AnimatedRabbit;

interface

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

type
  TMainForm = class(TForm)
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    FRabbit: TBitmap;
    FStartTime: TDateTime;
  const
    Speed = -100;
    function GetRabbitLeft: Double;
  protected
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  public

  end;

var
  MainForm: TMainForm;

implementation

uses
  DateUtils;

{$R *.dfm}

procedure TMainForm.FormCreate(Sender: TObject);
begin
  FRabbit := TBitmap.Create;
  FRabbit.LoadFromFile('K:\rabbit.bmp');
  FStartTime := Now;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  FreeAndNil(FRabbit);
end;

procedure TMainForm.FormPaint(Sender: TObject);
var
  x: Integer;
begin
  x := Round(GetRabbitLeft);
  BitBlt(
    Canvas.Handle,
    x,
    0,
    FRabbit.Width,
    FRabbit.Height,
    FRabbit.Canvas.Handle,
    0,
    0,
    SRCCOPY
  );
  Canvas.Brush.Color := Color;
  if x > 0 then
    Canvas.FillRect(Rect(0, 0, x - 1, ClientHeight));
  if x + FRabbit.Width < ClientWidth then
    Canvas.FillRect(Rect(x + FRabbit.Width, 0, ClientWidth, ClientHeight));
end;

function TMainForm.GetRabbitLeft: Double;
begin
  Result := ClientWidth + Speed * SecondSpan(Now, FStartTime);
end;

procedure TMainForm.Timer1Timer(Sender: TObject);
begin
  Invalidate;
  if GetRabbitLeft + FRabbit.Width < 0 then
    Timer1.Enabled := False;
end;

procedure TMainForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

end.

~~我认为这是您使用 GDI（1980 年代的图形 API）所能做到的最好的了。我打赌它在 Direct2D（或 OpenGL，如果你喜欢的话）中看起来会更好。~~

更新

经过进一步调查，我怀疑通常的计时器不够好。问题有两个：(1) 普通计时器可获得的最佳 FPS 太低。 (2) 事实上，两个连续的 WM_TIMER 消息之间的持续时间不恒定会导致视觉问题。

如果我改用高分辨率 multimedia timer，忽略它们已被弃用的事实，我会得到更好的结果：

unit AnimatedRabbit;

interface

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

const
  WM_DOINVALIDATE = WM_USER + 1;

type
  TMainForm = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FRabbit: TBitmap;
    FStartTime: TDateTime;
    FMMEvent: Cardinal;
  const
    Speed = -100;
    function GetRabbitLeft: Double;
  protected
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMDoInvalidate(var Message: TMessage); message WM_DOINVALIDATE;
  public

  end;

var
  MainForm: TMainForm;

implementation

uses
  DateUtils, MMSystem, Math;

{$R *.dfm}

procedure RepaintFunc(wTimerID: UINT; msg: UINT; dwUser: NativeUINT;
  dw1, dw2: NativeUINT); stdcall;
begin
  PostMessage(MainForm.Handle, WM_DOINVALIDATE, 0, 0);
end;

procedure TMainForm.FormCreate(Sender: TObject);
const
  TargetResolution = 1;
var
  tc: TTimeCaps;
  res: Cardinal;
begin
  FRabbit := TBitmap.Create;
  FRabbit.LoadFromFile('K:\rabbit.bmp');
  FStartTime := Now;
  if timeGetDevCaps(@tc, SizeOf(tc)) <> TIMERR_NOERROR then
    Exit;
  res := EnsureRange(TargetResolution, tc.wPeriodMin, tc.wPeriodMax);
  if timeBeginPeriod(res) <> TIMERR_NOERROR then
    Exit;
  FMMEvent := timeSetEvent(10, res, RepaintFunc, 0, TIME_PERIODIC);
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  timeKillEvent(FMMEvent);
  FreeAndNil(FRabbit);
end;

procedure TMainForm.FormPaint(Sender: TObject);
var
  x: Integer;
begin
  x := Round(GetRabbitLeft);
  BitBlt(
    Canvas.Handle,
    x,
    0,
    FRabbit.Width,
    FRabbit.Height,
    FRabbit.Canvas.Handle,
    0,
    0,
    SRCCOPY
  );
  Canvas.Brush.Color := Color;
  if x > 0 then
    Canvas.FillRect(Rect(0, 0, x - 1, ClientHeight));
  if x + FRabbit.Width < ClientWidth then
    Canvas.FillRect(Rect(x + FRabbit.Width, 0, ClientWidth, ClientHeight));
end;

function TMainForm.GetRabbitLeft: Double;
begin
  Result := ClientWidth + Speed * SecondSpan(Now, FStartTime);
end;

procedure TMainForm.WMDoInvalidate(var Message: TMessage);
begin
  Invalidate;
end;

procedure TMainForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

end.

更新 2

这是未弃用的版本：

unit AnimatedRabbit;

interface

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

const
  WM_DOINVALIDATE = WM_USER + 1;

type
  TMainForm = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FRabbit: TBitmap;
    FStartTime: TDateTime;
    FTimer: THandle;
  const
    Speed = -100;
    function GetRabbitLeft: Double;
  protected
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMDoInvalidate(var Message: TMessage); message WM_DOINVALIDATE;
  public

  end;

var
  MainForm: TMainForm;

implementation

uses
  DateUtils, Math;

{$R *.dfm}

procedure RepaintFunc(Context: Pointer; Success: Boolean); stdcall;
begin
  PostMessage(MainForm.Handle, WM_DOINVALIDATE, 0, 0);
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  FRabbit := TBitmap.Create;
  FRabbit.LoadFromFile('K:\rabbit.bmp');
  FStartTime := Now;
  if not CreateTimerQueueTimer(FTimer, 0, RepaintFunc, nil, 0, 10, 0) then
    RaiseLastOSError;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  DeleteTimerQueueTimer(0, FTimer, INVALID_HANDLE_VALUE);
  FreeAndNil(FRabbit);
end;

procedure TMainForm.FormPaint(Sender: TObject);
var
  x: Integer;
begin
  x := Round(GetRabbitLeft);
  BitBlt(
    Canvas.Handle,
    x,
    0,
    FRabbit.Width,
    FRabbit.Height,
    FRabbit.Canvas.Handle,
    0,
    0,
    SRCCOPY
  );
  Canvas.Brush.Color := Color;
  if x > 0 then
    Canvas.FillRect(Rect(0, 0, x - 1, ClientHeight));
  if x + FRabbit.Width < ClientWidth then
    Canvas.FillRect(Rect(x + FRabbit.Width, 0, ClientWidth, ClientHeight));
end;

function TMainForm.GetRabbitLeft: Double;
begin
  Result := ClientWidth + Speed * SecondSpan(Now, FStartTime);
end;

procedure TMainForm.WMDoInvalidate(var Message: TMessage);
begin
  Invalidate;
end;

procedure TMainForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

end.

另外，我之前说过，精确的结果取决于CPU、GPU、OS和显示器。但这也取决于眼睛和大脑。使此动画需要如此高质量计时器的原因在于，运动是一个简单的恒定速度平移，眼睛和大脑可以轻松发现任何缺陷。如果我们有一个弹跳球或 SHM 的动画，一个老式计时器就足够了。

Answer 3

您可以使用AnimateWindow

这是 DFM。只需在 TPanel

内添加 client aligned TPicture

object Form30: TForm30
  Left = 0
  Top = 0
  Caption = 'Form30'
  ClientHeight = 337
  ClientWidth = 389
  Color = clBtnFace
  DoubleBuffered = True
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Panel1: TPanel
    Left = 0
    Top = 0
    Width = 389
    Height = 289
    Align = alTop
    BevelOuter = bvNone
    Color = clRed
    FullRepaint = False
    ParentBackground = False
    ShowCaption = False
    TabOrder = 0
    Visible = False
  end
  object Button1: TButton
    Left = 136
    Top = 304
    Width = 75
    Height = 25
    Caption = 'Button1'
    TabOrder = 1
    OnClick = Button1Click
  end
end

和 Button1.OnClick 处理程序：

procedure TForm30.Button1Click(Sender: TObject);
begin
    AnimateWindow(Panel1.Handle, 1000, AW_SLIDE or AW_HOR_POSITIVE or AW_ACTIVATE);
end;

图片滑动效果。 BitBlt 闪闪发光

Image slide effect. BitBlt shimmers

delphi

更新

更新 2