1

我正在 Delphi 7 下编写一个动画程序，包括在画布上移动两个圆盘（我选择一个 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.

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

谢谢

4

2 回答 2

1

你的代码几乎没问题。

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

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

计时器间隔 1 似乎有点矫枉过正。我会将其设置为 1000 div 120 (120 FPS)。

我会将双缓冲设置为 false，因为您已经在进行自己的双缓冲。此外，我会将表单的 OnPaint 移动到 Paintbox 的 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;
于 2021-02-14T18:35:10.483 回答
0

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

   // Collect the old rects into the update-rect

       {      if i = 0 then
      Runion := ROld
       else
      UnionRect(Runion, Runion, ROld);    }
于 2021-02-16T13:27:25.020 回答