Delphi Graphics32如何用鼠标在图层上画线
Delphi Graphics32 how to draw a line with the mouse on a layer
谁能帮我把这种动态画线的好方法 (Photoshop style drawing line with delphi) 转换成 Graphics32？
我的意思是，我想要一个 ImgView，向其添加一个新层，然后在该层而不是窗体的 canvas.
上执行这些方法
所以我假设，我的代码应该是这样的：
private
FStartPoint, FEndPoint: TPoint;
FDrawingLine: boolean;
bm32: TBitmap32;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
bm32 := TBitmap32.Create;
FDrawingLine := false;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
with ImgView do
begin
Selection := nil;
RBLayer := nil;
Layers.Clear;
Scale := 1;
Bitmap.SetSize(800, 600);
Bitmap.Clear(clWhite32);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
B : TBitmapLayer;
P: TPoint;
W, H: Single;
begin
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
Bitmap.DrawMode := dmBlend;
with ImgView.Bitmap do Location := GR32.FloatRect(0, 0, 600, 400);
Scaled := True;
OnMouseDown := LayerMouseDown;
OnMouseUp := LayerMouseUp;
OnMouseMove := LayerMouseMove;
OnPaint := LayerOnPaint;
except
Free;
raise;
end;
end;
我假定此代码是因为这些是 link 中常规 canvas 绘图方法中使用的事件，但其余方法无法正常工作
procedure TForm1.AddLineToLayer;
begin
bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;
procedure TForm1.SwapBuffers32;
begin
BitBlt(imgView.Canvas.Handle, 0, 0, ClientWidth, ClientHeight,bm32.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TForm1.SwapBuffers;
begin
BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight,
bm.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TForm1.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
FStartPoint := Point(X, Y);
FDrawingLine := true;
end;
procedure TForm1.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
FDrawingLine := false;
FEndPoint := Point(X, Y);
AddLineToLayer;
SwapBuffers;
end;
procedure TForm1.LayerMouseMove(Sender: TObject; Shift: TShiftState;X, Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers;
ImgView.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
ImgView.Canvas.LineTo(X, Y);
end;
end;
procedure TForm1.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
SwapBuffers;
end;
所以它不起作用。什么都没发生。
任何人都可以帮助我像正常 canvas 绘图一样完成这项工作吗？
我只想让一层发生这种情况，我用 Button1Click 创建的层......
（ImgView是放在窗体上的ImgView32控件，窗体上也有一个按钮）
结果看起来像这样（错误提示 Canvas 不允许绘图）
第一次出现onButtonClick错误，然后Ok it后，开始绘图，它没有擦除移动线（就像上图），然后onMouseUp再次出现Canvas错误。
我做错了什么？
如果我使用 SwapBuffers32，则不会绘制任何内容，并且 canvas 错误不断出现。
编辑：
我做了一些更改，只是为了尝试在 Tom Brunberg 的建议后让它工作，最后我得到了这个代码：
private
FStartPoint, FEndPoint: TPoint;
FDrawingLine: boolean;
bm32: TBitmap32;
B : TBitmapLayer;
FSelection: TPositionedLayer;
public
procedure AddLineToLayer;
procedure SwapBuffers32;
procedure LayerMouseDown(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
procedure LayerMouseUp(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
procedure LayerMouseMove(Sender: TObject; Shift: TShiftState;X, Y: Integer);
procedure LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
procedure SetSelection(Value: TPositionedLayer);
property Selection: TPositionedLayer read FSelection write SetSelection;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var
P: TPoint;
W, H: Single;
begin
bm32 := TBitmap32.Create;
bm32.SetSize(800,600);
with ImgView do
begin
Selection := nil;
Layers.Clear;
Scale := 1;
Bitmap.SetSize(800, 600);
Bitmap.Clear(clWhite32);
end;
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
Bitmap.DrawMode := dmBlend;
B.Bitmap.SetSize(800,600);
with ImgView.Bitmap do Location := GR32.FloatRect(0, 0, 800, 600);
Scaled := True;
OnMouseDown := LayerMouseDown;
OnMouseUp := LayerMouseUp;
OnMouseMove := LayerMouseMove;
OnPaint := LayerOnPaint;
except
Free;
raise;
end;
FDrawingLine := false;
end;
procedure TForm1.AddLineToLayer;
begin
bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;
procedure TForm1.SwapBuffers32;
begin
// BitBlt(imgView.Canvas.Handle, 0, 0, ClientWidth, ClientHeight,bm32.Canvas.Handle, 0, 0, SRCCOPY);
BitBlt(B.Bitmap.Canvas.Handle, 0, 0, ClientWidth, ClientHeight,bm32.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TForm1.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
FStartPoint := Point(X, Y);
FDrawingLine := true;
end;
procedure TForm1.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
FDrawingLine := false;
FEndPoint := Point(X, Y);
AddLineToLayer;
SwapBuffers32;
end;
procedure TForm1.LayerMouseMove(Sender: TObject; Shift: TShiftState;X, Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers32;
ImgView.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
ImgView.Canvas.LineTo(X, Y);
end;
end;
procedure TForm1.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
SwapBuffers32;
end;
procedure TForm1.SetSelection(Value: TPositionedLayer);
begin
if Value <> FSelection then
begin
FSelection := Value;
end;
end;
现在，不再有 Canvas 错误，但鼠标移动线保持绘制...解决方案必须在 BitBlt 函数 (swapbuffers32) 中。有什么想法吗？
要了解无法删除不需要的行的问题，我们需要回顾一下 Anders Rejbrands 解决方案的工作原理。
内存位图 bm 是我们存储 wanted 行的位图。表单的 canvas 充当垫板，我们可以在其中捕获鼠标操作并向用户提供反馈。在 MouseDown 和 MouseUp 事件（确定想要的起点和终点）之间，我们收到很多 MouseMove 事件。对于每个 MouseMove，我们首先调用 SwapBuffers，它 擦除 表单 canvas 中的任何垃圾（之前 MouseMove 留下的）。然后我们绘制从起点到当前鼠标位置的线。擦除是通过将 bm 的内容复制 (BitBlt) 到形式 canvas.
来完成的
由于删除不需要的行不起作用，我们需要仔细查看您代码中的 bm32。你在 FormCreate 中创建它，但你从来没有给它一个大小！这就是问题所在。 SwapBuffers32.
中没有可复制的内容
另外，由于位图没有大小，所以无法绘制。因此错误消息。
SwapBuffer 的另一个版本引用了一个 bm 变量，它没有在任何其他代码中显示，所以我根本无法对此发表评论。
更新用户代码后编辑。
在FormCreate中，设置bm32的大小后，添加
bm32.Clear(clWhite32); // Add this line
并更改以下两行
// with ImgView.Bitmap do Location := GR32.FloatRect(0, 0, 800, 600);
B.Location := GR32.FloatRect(0, 0, 800, 600);
// Scaled := True;
Scaled := False;
最后在 FormCreate 的末尾添加
SwapBuffers32;
在 LayerMouseMove 中用 B.BitMap
替换 ImgView
// ImgView.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
// ImgView.Canvas.LineTo(X, Y);
B.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
B.Bitmap.Canvas.LineTo(X, Y);
并在 SwapBuffers32 中将 ClientWidth 和 ClienHeight 替换为 B.Bitmap
的属性
BitBlt(B.Bitmap.Canvas.Handle, 0, 0, B.Bitmap.Width, B.Bitmap.Height,bm32.Canvas.Handle, 0, 0, SRCCOPY);
这些更改对我有用，因此 bm32 仍会收集预期的行。由于 MouseUp 的最后一次调用是对 SwapBuffers 的调用，因此 B 层将获得这些行的最终副本。 ImgView.Bitmap 不涉及任何内容，因为您希望在图层上绘制。
根据用户评论进行编辑...
我确实又做了一处改动。抱歉忘记提及。
在 FormCreate 中，在 with B...
下
// Bitmap.DrawMode := dmBlend;
Bitmap.DrawMode := dmOpaque;
在 Firemonkey 中，我使用位图从 2 个点绘制直线。
基本上，在线条开始之前（鼠标按下、事件），您可以截取要绘制线条的区域。
然后当鼠标移动时在位图副本上画一条线。每次在位图上绘制线条之前，您都将位图替换为原始屏幕截图。可能需要稍微修改一下，但似乎工作正常。
在下面的代码中，图像与您要绘制的区域的客户端对齐。
代码....
procedure TForm3.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Single);
begin
if Button = TmouseButton.mbLeft then
begin
startPoint := pointf(X,Y);
endPoint := StartPoint;
saveScreen := Image1.MakeScreenshot;
Image1.Bitmap := saveScreen;
Panel1.HitTest := false;
end;
end;
procedure TForm3.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Single);
begin
if ssLeft in Shift then
begin
EndPoint := pointf(X,y);
Image1.Bitmap := saveScreen;
Image1.Bitmap.Canvas.BeginScene();
Image1.Bitmap.Canvas.Stroke.Color := TAlphaColorRec.Green;
Image1.Bitmap.Canvas.DrawLine(StartPoint, endPoint ,1);
Image1.Bitmap.Canvas.EndScene;
end;
end;
procedure TForm3.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Single);
begin
Image1.canvas.beginscene;
Image1.Bitmap := saveScreen;
Image1.canvas.endScene;
//Panel1.HitTest := true; ignore this for now.
end;
我认为fire monkey中可能还有另一种方法可以实现用鼠标画线，那就是在窗体上拖放一个TLine，将x,y的旋转角度设置为0。画线时创建从起点到终点的边界矩形，从起点（归一化矩形）算出边界矩形的三角形交点的旋转角度，并基本上将 TLine 的旋转角度更改为任何值。将线定位在起点，然后修改长度。无论如何的想法。可能是另一种方法。抱歉缺少这方面的代码...
谁能帮我把这种动态画线的好方法 (Photoshop style drawing line with delphi) 转换成 Graphics32？
我的意思是，我想要一个 ImgView，向其添加一个新层，然后在该层而不是窗体的 canvas.
上执行这些方法所以我假设，我的代码应该是这样的：
private
FStartPoint, FEndPoint: TPoint;
FDrawingLine: boolean;
bm32: TBitmap32;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
bm32 := TBitmap32.Create;
FDrawingLine := false;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
with ImgView do
begin
Selection := nil;
RBLayer := nil;
Layers.Clear;
Scale := 1;
Bitmap.SetSize(800, 600);
Bitmap.Clear(clWhite32);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
B : TBitmapLayer;
P: TPoint;
W, H: Single;
begin
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
Bitmap.DrawMode := dmBlend;
with ImgView.Bitmap do Location := GR32.FloatRect(0, 0, 600, 400);
Scaled := True;
OnMouseDown := LayerMouseDown;
OnMouseUp := LayerMouseUp;
OnMouseMove := LayerMouseMove;
OnPaint := LayerOnPaint;
except
Free;
raise;
end;
end;
我假定此代码是因为这些是 link 中常规 canvas 绘图方法中使用的事件，但其余方法无法正常工作
procedure TForm1.AddLineToLayer;
begin
bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;
procedure TForm1.SwapBuffers32;
begin
BitBlt(imgView.Canvas.Handle, 0, 0, ClientWidth, ClientHeight,bm32.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TForm1.SwapBuffers;
begin
BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight,
bm.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TForm1.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
FStartPoint := Point(X, Y);
FDrawingLine := true;
end;
procedure TForm1.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
FDrawingLine := false;
FEndPoint := Point(X, Y);
AddLineToLayer;
SwapBuffers;
end;
procedure TForm1.LayerMouseMove(Sender: TObject; Shift: TShiftState;X, Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers;
ImgView.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
ImgView.Canvas.LineTo(X, Y);
end;
end;
procedure TForm1.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
SwapBuffers;
end;
所以它不起作用。什么都没发生。 任何人都可以帮助我像正常 canvas 绘图一样完成这项工作吗？ 我只想让一层发生这种情况，我用 Button1Click 创建的层...... （ImgView是放在窗体上的ImgView32控件，窗体上也有一个按钮）
结果看起来像这样（错误提示 Canvas 不允许绘图）
我做错了什么？
如果我使用 SwapBuffers32，则不会绘制任何内容，并且 canvas 错误不断出现。
编辑： 我做了一些更改，只是为了尝试在 Tom Brunberg 的建议后让它工作，最后我得到了这个代码：
private
FStartPoint, FEndPoint: TPoint;
FDrawingLine: boolean;
bm32: TBitmap32;
B : TBitmapLayer;
FSelection: TPositionedLayer;
public
procedure AddLineToLayer;
procedure SwapBuffers32;
procedure LayerMouseDown(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
procedure LayerMouseUp(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
procedure LayerMouseMove(Sender: TObject; Shift: TShiftState;X, Y: Integer);
procedure LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
procedure SetSelection(Value: TPositionedLayer);
property Selection: TPositionedLayer read FSelection write SetSelection;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var
P: TPoint;
W, H: Single;
begin
bm32 := TBitmap32.Create;
bm32.SetSize(800,600);
with ImgView do
begin
Selection := nil;
Layers.Clear;
Scale := 1;
Bitmap.SetSize(800, 600);
Bitmap.Clear(clWhite32);
end;
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
Bitmap.DrawMode := dmBlend;
B.Bitmap.SetSize(800,600);
with ImgView.Bitmap do Location := GR32.FloatRect(0, 0, 800, 600);
Scaled := True;
OnMouseDown := LayerMouseDown;
OnMouseUp := LayerMouseUp;
OnMouseMove := LayerMouseMove;
OnPaint := LayerOnPaint;
except
Free;
raise;
end;
FDrawingLine := false;
end;
procedure TForm1.AddLineToLayer;
begin
bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;
procedure TForm1.SwapBuffers32;
begin
// BitBlt(imgView.Canvas.Handle, 0, 0, ClientWidth, ClientHeight,bm32.Canvas.Handle, 0, 0, SRCCOPY);
BitBlt(B.Bitmap.Canvas.Handle, 0, 0, ClientWidth, ClientHeight,bm32.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TForm1.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
FStartPoint := Point(X, Y);
FDrawingLine := true;
end;
procedure TForm1.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
FDrawingLine := false;
FEndPoint := Point(X, Y);
AddLineToLayer;
SwapBuffers32;
end;
procedure TForm1.LayerMouseMove(Sender: TObject; Shift: TShiftState;X, Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers32;
ImgView.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
ImgView.Canvas.LineTo(X, Y);
end;
end;
procedure TForm1.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
SwapBuffers32;
end;
procedure TForm1.SetSelection(Value: TPositionedLayer);
begin
if Value <> FSelection then
begin
FSelection := Value;
end;
end;
现在，不再有 Canvas 错误，但鼠标移动线保持绘制...解决方案必须在 BitBlt 函数 (swapbuffers32) 中。有什么想法吗？
要了解无法删除不需要的行的问题，我们需要回顾一下 Anders Rejbrands 解决方案的工作原理。
内存位图 bm 是我们存储 wanted 行的位图。表单的 canvas 充当垫板，我们可以在其中捕获鼠标操作并向用户提供反馈。在 MouseDown 和 MouseUp 事件（确定想要的起点和终点）之间，我们收到很多 MouseMove 事件。对于每个 MouseMove，我们首先调用 SwapBuffers，它 擦除 表单 canvas 中的任何垃圾（之前 MouseMove 留下的）。然后我们绘制从起点到当前鼠标位置的线。擦除是通过将 bm 的内容复制 (BitBlt) 到形式 canvas.
由于删除不需要的行不起作用，我们需要仔细查看您代码中的 bm32。你在 FormCreate 中创建它，但你从来没有给它一个大小！这就是问题所在。 SwapBuffers32.
另外，由于位图没有大小，所以无法绘制。因此错误消息。
SwapBuffer 的另一个版本引用了一个 bm 变量，它没有在任何其他代码中显示，所以我根本无法对此发表评论。
更新用户代码后编辑。
在FormCreate中，设置bm32的大小后，添加
bm32.Clear(clWhite32); // Add this line
并更改以下两行
// with ImgView.Bitmap do Location := GR32.FloatRect(0, 0, 800, 600);
B.Location := GR32.FloatRect(0, 0, 800, 600);
// Scaled := True;
Scaled := False;
最后在 FormCreate 的末尾添加
SwapBuffers32;
在 LayerMouseMove 中用 B.BitMap
替换 ImgView// ImgView.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
// ImgView.Canvas.LineTo(X, Y);
B.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
B.Bitmap.Canvas.LineTo(X, Y);
并在 SwapBuffers32 中将 ClientWidth 和 ClienHeight 替换为 B.Bitmap
的属性 BitBlt(B.Bitmap.Canvas.Handle, 0, 0, B.Bitmap.Width, B.Bitmap.Height,bm32.Canvas.Handle, 0, 0, SRCCOPY);
这些更改对我有用，因此 bm32 仍会收集预期的行。由于 MouseUp 的最后一次调用是对 SwapBuffers 的调用，因此 B 层将获得这些行的最终副本。 ImgView.Bitmap 不涉及任何内容，因为您希望在图层上绘制。
根据用户评论进行编辑...
我确实又做了一处改动。抱歉忘记提及。
在 FormCreate 中，在 with B...
// Bitmap.DrawMode := dmBlend;
Bitmap.DrawMode := dmOpaque;
在 Firemonkey 中，我使用位图从 2 个点绘制直线。
基本上，在线条开始之前（鼠标按下、事件），您可以截取要绘制线条的区域。
然后当鼠标移动时在位图副本上画一条线。每次在位图上绘制线条之前，您都将位图替换为原始屏幕截图。可能需要稍微修改一下，但似乎工作正常。 在下面的代码中，图像与您要绘制的区域的客户端对齐。
代码....
procedure TForm3.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Single);
begin
if Button = TmouseButton.mbLeft then
begin
startPoint := pointf(X,Y);
endPoint := StartPoint;
saveScreen := Image1.MakeScreenshot;
Image1.Bitmap := saveScreen;
Panel1.HitTest := false;
end;
end;
procedure TForm3.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Single);
begin
if ssLeft in Shift then
begin
EndPoint := pointf(X,y);
Image1.Bitmap := saveScreen;
Image1.Bitmap.Canvas.BeginScene();
Image1.Bitmap.Canvas.Stroke.Color := TAlphaColorRec.Green;
Image1.Bitmap.Canvas.DrawLine(StartPoint, endPoint ,1);
Image1.Bitmap.Canvas.EndScene;
end;
end;
procedure TForm3.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Single);
begin
Image1.canvas.beginscene;
Image1.Bitmap := saveScreen;
Image1.canvas.endScene;
//Panel1.HitTest := true; ignore this for now.
end;
我认为fire monkey中可能还有另一种方法可以实现用鼠标画线，那就是在窗体上拖放一个TLine，将x,y的旋转角度设置为0。画线时创建从起点到终点的边界矩形，从起点（归一化矩形）算出边界矩形的三角形交点的旋转角度，并基本上将 TLine 的旋转角度更改为任何值。将线定位在起点，然后修改长度。无论如何的想法。可能是另一种方法。抱歉缺少这方面的代码...