如何在 canvas 上移动两个位图图像

Question

我正在 Delphi 7 下编写动画程序，包括在 canvas（我选择 PaintBox）上移动两个圆盘，边缘有弹跳效果。

一张一张加载就好了：这样的话，时不时来的两个圆盘叠加时，没有出现背景矩形，透明效果也还不错。

但是如果我尝试通过引入例如 Record 来推广更多光盘的操作。

运动没问题，但在这种情况下，当圆盘交叉时，背景矩形出现在上图中，破坏了一切！

我什至尝试用对象编写代码：

    TSphere = class (TObject)

但没办法，现象依旧..

你知道如何消除这个显示缺陷吗？

我还有一个问题，我想用纹理填充磁盘。

完整代码：

    unit Unit1;

    interface

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


    type
    TSphere = record
    W, H: integer;
    vx, vy: Extended;
    x, y: integer;
    xx, yy: extended;
    ROld, RNew: TRect;
    Bitm: TBitmap;
    end;

    type
    TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Button1: TButton;
    Timer1: TTimer;
    Label1: TLabel;
    Edit1: TEdit;
    Label2: TLabel;
    TrackBar1: TTrackBar;

    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure TrackBar1Change(Sender: TObject);
    end;

    var
    Form1: TForm1;

    fin: boolean;
    BmpBkg: Tbitmap;
    BmpMoving: TBitmap;

    Spheres: array of TSphere;

    const
    nb = 2;
    ImageWidth = 32;

    implementation

    {$R *.DFM}

    procedure PictureStorage;
    var
    i: integer;
    begin
    SetLength(Spheres, nb);
    for i := 0 to (nb - 1) do
    begin
      with Spheres[i] do
       begin
        Bitm := TBitmap.Create;
         case i of
           0: Bitm.loadFromFile('Sphere1.bmp');
           1: Bitm.loadFromFile('Sphere2.bmp');
         end;
       end;
     end;
     end;

    procedure TForm1.FormCreate(Sender: TObject);
    var
    i: integer;
    begin
    DoubleBuffered := true;
    randomize;
    Fin := false;

    BmpBkg := TBitmap.Create;
    BmpMoving := TBitmap.Create;

    BmpBkg .Canvas.Brush.Color := ClBtnFace;
    BmpBkg .Canvas.FillRect(Rect(0, 0, PaintBox1.height, 
    PaintBox1.width));
    BmpBkg .Width := PaintBox1.Width;
    BmpBkg .Height := PaintBox1.Height;
    BmpMoving .Assign(BmpBkg );

    PictureStorage;

      for i := 0 to (nb - 1) do
      begin
      with Spheres[i] do
        begin
        W := Bitm.Width;
        H := Bitm.Height;
        Bitm.Transparent := True;
        Bitm.TransParentColor := Bitm.canvas.pixels[1, 1];

        xx := random(400) + 1;
        yy := random(200) + 1;
         x := trunc(xx);
         y := trunc(yy);
         vx := random(3) + 1;
         vy := random(4) + 1;
         RNew := bounds(x, y, W, H);
         ROld := RNew;
        end;
       end;

       Timer1.interval := 1;
       Timer1.enabled := true;
       end;

       procedure TForm1.FormDestroy(Sender: TObject);
       var
       i: integer;
        begin
        Fin := true;
        BmpBkg.free;
        BmpMoving.free;

         for i := 0 to (nb - 1) do
          Spheres[i].Bitm.Free;
         end;

      procedure TForm1.FormPaint(Sender: TObject);
      begin
        PaintBox1.Canvas.Draw(0, 0, BmpMoving);
      end;

      procedure TForm1.Button1Click(Sender: TObject);
       begin
         close;
       end;

      procedure TForm1.Timer1Timer(Sender: TObject);
        var
        n, i: integer;
       Runion: Trect;
         begin
          for n := 1 to trackbar1.position do
           begin
               if fin then exit;
            for i := 0 to (nb - 1) do
            begin
             with Spheres[i] do
              begin
                BmpMoving.Canvas.CopyRect(ROld, bmpBkg.canvas, ROld);

              if (x < -ImageWidth) or (x > bmpBkg.width - W + ImageWidth) 
                then
               vx := -vx;
                if (y < 0) or (y > bmpBkg.height - H) then
                vy := -vy;
                xx := xx + vx;
                yy := yy + vy;
                 x := trunc(xx);
                 y := trunc(yy);
                RNew := bounds(x, y, W, H);
                BmpMoving.Canvas.Draw(x, y, Bitm);

                UnionRect(RUnion, ROld, RNew);
                PaintBox1.Canvas.CopyRect(RUnion, BmpMoving.Canvas, 
                RUnion);
                ROld := RNew;
                end;
               end;
              end;
             end;

        procedure TForm1.TrackBar1Change(Sender: TObject);
          begin
           Edit1.text := inttostr(trackbar1.position);
             if trackbar1.position = 1 then
               label2.visible := true
                else
             label2.visible := false;
           end;

        end.

这个项目只是另一个更重要的项目的开始

谢谢

Answer 1

你的代码差不多OK了。

据我所知，您的问题是由于在新位置绘制位图之前没有完全恢复背景造成的。在绘制新球体之前，您需要恢复 all 球体的旧矩形。在更新到屏幕之前，您还需要收集所有新旧矩形的完整并集。

根据个人喜好，我会避免使用全局变量并将它们设为表单的字段。如果您也将 PictureStorage 设为窗体的方法，则一切正常。

1 的定时器间隔似乎有点过分了。我会将其设置为 1000 div 120（120 FPS）。

我会将 doublebuffered 设置为 false，因为您已经在进行自己的双缓冲。此外，我会将表单的 OnPaint 移动到绘画盒的 OnPaint，但这似乎对您不起作用。

这是对 OnTimer 事件的替换，它应该可以工作（我用 Delphi 2006 检查了一个模拟，我没有再安装 Delphi7，我不知道是什么n 表示）。

procedure TForm1.Timer1Timer(Sender: TObject);
var
  n, i: integer;
  Runion: TRect;
begin
  //I don't know what the n-loop is for, in my test I left it out
  for n := 1 to TrackBar1.position do
  begin
    //prevent reentry?
    if fin then
      exit;
    // Restore the background completely
    for i := 0 to (nb - 1) do
      with Spheres[i] do
      begin
        BmpMoving.Canvas.CopyRect(ROld, BmpBkg.Canvas, ROld);
        // Collect the old rects into the update-rect
        if i = 0 then
          Runion := ROld
        else
          UnionRect(Runion, Runion, ROld);
      end;
    for i := 0 to (nb - 1) do
      with Spheres[i] do
      begin
        if (x < -ImageWidth) or (x > BmpBkg.width - W + ImageWidth) then
          vx := -vx;
        if (y < 0) or (y > BmpBkg.height - H) then
          vy := -vy;
        xx := xx + vx;
        yy := yy + vy;
        x := trunc(xx);
        y := trunc(yy);
        RNew := bounds(x, y, W, H);
        BmpMoving.Canvas.Draw(x, y, Bitm);
        // Add RNew to RUnion
        UnionRect(Runion, Runion, RNew);
        // No painting yet, update the screen as few times as possible
        ROld := RNew;
      end;
    //Now update the screen
    //This is the reliable way for sherlock to update the screen:
    OffsetRect(RUnion, Paintbox1.left, Paintbox1.top); 
    //RUnion in form's coordinates
    InvalidateRect(Handle, @RUnion, false);
    //The following works for me just as well:
    (**************
    PaintBox1.Canvas.CopyRect(Runion, BmpMoving.Canvas, Runion);
    ***************)
  end;
end;

Answer 2

这段代码可以注释掉。 Tt 不影响程序:

   // Collect the old rects into the update-rect

       {      if i = 0 then
      Runion := ROld
       else
      UnionRect(Runion, Runion, ROld);    }

如何在 canvas 上移动两个位图图像

how to move two bitmap-image on a canvas

delphi

delphi-7

tcanvas