TImage ohne Ruckeln auf einem Form bewegen

[Uwe Raabe]

Der folgende Beispielcode sendet wiederholt Windows-Messages an das Form, um eine Neuberechneung der Image-Position zu triggern. Je nach abgelaufener Zeit wird die Bildposition neu berechnet und bei einer Änderung der Bildkoordinaten ein Neuzeichnen forciert. Damit wird sichergestellt, daß die Strecke auch in der angegebenen Zeit zurückgelegt wird, selbst auf einem langsamen System (das kann dann auch mal springen).

Beim Form ist DoubleBuffered = true. Das zweite Image ist nur ein Hintergrundbild, um die Transparenz zu überprüfen.

Delphi-Quellcode:

unit Unit19;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, pngimage, jpeg, ExtCtrls, Diagnostics;

const
  wm_MoveImage = wm_User + 1;

type
  TForm19 = class(TForm)
    Image: TImage;
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    FStartPos: Integer;
    FStopWatch: TStopWatch;
    FTimeToMoveInMs: Integer;
    FEndPos: Integer;
    function MoveImage: Boolean;
    procedure TriggerMove;
  protected
    procedure WMMoveImage(var Message: TMessage); message WM_MOVEIMAGE;
  public
    property StartPos: Integer read FStartPos write FStartPos;
    property StopWatch: TStopWatch read FStopWatch write FStopWatch;
    property TimeToMoveInMs: Integer read FTimeToMoveInMs write FTimeToMoveInMs;
    property EndPos: Integer read FEndPos write FEndPos;
  end;

var
  Form19: TForm19;

implementation

{$R *.dfm}

procedure TForm19.Button1Click(Sender: TObject);
begin
  { Start- und Endposition und Zeitspanne festlegen }
  StartPos := 100;
  EndPos := 400;
  TimeToMoveInMs := 3000;
  { Zeitmesser starten }
  StopWatch := TStopWatch.StartNew;
  { erste Bewegung auslösen }
  TriggerMove;
end;

procedure TForm19.WMMoveImage(var Message: TMessage);
begin
  { solange wir das Ziel nicht erreicht haben, triggern wir gleich die nächste Bewegung }
  if MoveImage then
    TriggerMove;
  Message.Result := 0;
  inherited;
end;

procedure TForm19.TriggerMove;
begin
  PostMessage(Handle, wm_MoveImage, 0, 0);
end;

function TForm19.MoveImage: Boolean;
var
  part: Extended;
  newPos: Integer;
begin
  if Image.Left <> EndPos then begin
    part := StopWatch.ElapsedMilliseconds / TimeToMoveInMs;
    if part > 1 then
      newPos := EndPos
    else
      newPos := StartPos + Round(part * (EndPos - StartPos));
    if newPos <> Image.Left then begin
      Image.Left := newPos;
      { Das Refresh ist nötig, da wir die Message-Queue so mit unseren eigenen Botschaften zumüllen, 
        daß keine Zeit für einen Bildaufbau bleibt. }
      Image.Refresh;
    end;
  end;
  { Solange wir das Ziel nicht erreicht haben, geben wir true zurück }
  result := (Image.Left <> EndPos);
end;

end.