delphi - 图片滑动效果。 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 处理程序中绘制表单。我不知道你是否这样做，但你应该这样做。

其次，您不能真正依赖连续 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、操作系统和显示器。但这也取决于眼睛和大脑。使此动画需要如此高质量计时器的原因在于，运动是一个简单的恒定速度平移，眼睛和大脑可以轻松发现任何缺陷。如果我们有一个弹跳球或 SHM 的动画，一个老式计时器就足够了。