Image slide effect. BitBlt shimmers

Question

I want to create a slide effect: one bitmap is painted from right to left on a form's canvas. For this I use BitBlt.

I call this function in a Timer (20ms):

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;

However, the image does not progress smoothly. It has some kind of flicker, but not the kind of flicker that we know in the VCL. It is difficult to describe it. It is like the image moves two pixels forward and then one pixel backward.

How to make the image move smoothly? Could the actually be caused by the refresh rate of the monitor?

Update: I don't know why, but it is caused by the timer. If I call Slide() in a 'for' loop then the animation is smooth. I know that the timer has an accuracy of ~15ms, but I still don't get it why it makes the image to shimmer. If I add a sleed(1) inside the loop the shimmer effect appears again, and it is even worse. It really looks like the image is drawn twice.

user_282848 · Answer

First, you should only paint on the form in the form's OnPaint handler. I don't know if you do that or not, but you should do so.

Second, you cannot really rely on the temporal distance between successive WM_TIMER messages being very precise or even constant. So it is better to check the actual time each time you paint. For instance, you may use the formula Position = Original Position + Velocity × Time known from school physics.

Also, to avoid flickering, you should probably handle WM_ERASEBKGND.

Putting these together,

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.

~~I think this is as good as you can make it using GDI (a graphics API from the 1980s). I bet it will look better in Direct2D (or OpenGL, if you prefer that).~~

Update

After further investigation, I suspect that the usual timer isn't good enough. The problem is two-fold: (1) The best FPS obtainable by a normal timer is too low. (2) The fact that the duration between two consecutive WM_TIMER messages isn't constant causes visual issues.

If I instead use a high-resolution multimedia timer, ignoring the fact that they are deprecated, I get a nicer result:

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.

Update 2

And here is the non-deprecated version:

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.

Also, I previously said that the precise result depends on CPU, GPU, OS, and monitor. But it also depends on the eye and brain. The thing that makes this animation require such a high-quality timer is the fact that the motion is a simple translation with constant velocity, and the eye + brain can easily spot any imperfection. If we had animated a bouncing ball or SHM, an old-school timer would have been enough.

user_65863 · Answer

You should not be drawing on the Form's Canvas from outside of its OnPaint event at all. All of the drawing should be in the OnPaint event only. Have your timer save the desired information into variables that the Form can access, and then Invalidate() the Form, and let its OnPaint event draw the image using the latest saved information.

Alternatively, simply display your BMP inside a TImage control, and then have the timer set that control's Left/Top/Width/Height properties as needed. Let the TImage handle the drawing of the image for you.

user_611563 · Answer

You can use AnimateWindow

Here's the DFM. Just add client aligned TPicture inside the TPanel

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

And the Button1.OnClick handler:

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

Image slide effect. BitBlt shimmers

3 Answers

Update

Update 2