如何在画布上移动两个位图图像
Posted
技术标签:
【中文标题】如何在画布上移动两个位图图像【英文标题】：how to move two bitmap-image on a canvas 【发布时间】：2021-02-13 12:13:41 【问题描述】：我正在 Delphi 7 下编写一个动画程序，包括在画布上移动两个圆盘（我选择一个 PaintBox），边缘有反弹效果。
我一张一张加载图片就可以了：这种情况下，时不时到的两个磁盘叠加在一起，就没有背景矩形出现，甚至还有相当悦目的透明效果。
但是，如果我尝试通过引入例如 Record 来概括使用更多光盘的操作。
动作没问题，但在这种情况下，当圆盘交叉时，背景 矩形出现在上面的图像中，破坏了一切！
我什至尝试用 Object 编写代码：
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.
这个节目只是另一个更重要的节目的开始
谢谢
【问题讨论】：
您没有展示更有趣的代码：绘制位图的代码。请编辑您的问题。请注意，问题可能是您没有正确处理位图中背景的透明度。另外请注意，如果你想画圆圈，不要使用位图！只需使用 TCanvas 方法绘制圆（椭圆）。选择纯色或纹理所需的画笔。 您使用的标签非常广泛。我建议你只使用 Delphi-7。 你好 François Piette，我放了完整的代码.. 我没看懂标签！ 标签用于过滤读者（如我）提出的问题，以缩小感兴趣的主题。它应该反映您遇到的问题。例如，您的问题不是动画问题，而是 Delphi 画布绘画问题。 IMO 这里唯一有趣的标签是 Delphi-7。 尝试以下操作：使用“离屏位图”来绘制背景和球体。使用BitBlt()将“离屏位图”一次性传到屏幕上。
【参考方案1】：
您的代码几乎没问题。
据我所知，您的问题是由于在新位置绘制位图之前没有完全恢复背景造成的。在绘制新球体之前，您需要恢复 all 球体的旧矩形。此外，您还需要在更新到屏幕之前收集所有新旧矩形的完整并集。
出于个人喜好，我会避免使用全局变量并将它们设为表单字段。如果您还使 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;
【讨论】：
【参考方案2】：这段代码可以被注释掉。 tt不影响程序：
// Collect the old rects into the update-rect
if i = 0 then
Runion := ROld
else
UnionRect(Runion, Runion, ROld);
【讨论】：
错了。没有这些行，RUNion 是未初始化的，可以是任何东西。此外，简单的逻辑告诉您，球体过去所在的矩形需要成为更新矩形的一部分。不要使用“实验性编程”。以上是关于如何在画布上移动两个位图图像的主要内容，如果未能解决你的问题，请参考以下文章