Delphi Graphics32如何在图层上用鼠标画线答案

【问题标题】：Delphi Graphics32 how to draw a line with the mouse on a layerDelphi Graphics32如何在图层上用鼠标画线
【发布时间】：2015-04-15 03:45:59
【问题描述】：

谁能帮我把这个动态画线(Photoshop style drawing line with delphi)的好方法转换成Graphics32？

我的意思是，我想要一个 ImgView，向它添加一个新层，然后在该层而不是表单的画布上执行这些方法。

所以我假设，我的代码应该是这样的：

 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;

我假设这段代码是因为这些是来自链接的常规画布绘图方法中使用的事件，但其余方法无法正常工作

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;

所以它不起作用。什么都没发生。任何人都可以帮助我像普通的画布绘图一样制作这项工作吗？我只想在一个图层上实现这一点，即我使用 Button1Click 创建的图层... （ImgView是放置在窗体上的ImgView32控件，窗体上还有一个按钮）

结果如下所示（错误提示 Canvas 不允许绘图）第一次出现onButtonClick错误，然后I Ok it，我开始绘制，它并没有擦除移动线（就像上图一样），然后再次出现onMouseUp Canvas错误。

我做错了什么？

如果我使用 SwapBuffers32，则不会绘制任何内容，并且画布错误会不断出现。

编辑：根据 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) 中。有什么想法吗？

【问题讨论】：

有趣的是，这个问题是如何因为没有研究工作或没有帮助而被降级的？！？！？！真的吗？我想知道这是谁做的……在 2 天内，这个问题被浏览了 97 次，但您仍然觉得它没有帮助？或者也许你可以在谷歌的任何地方找到这个问题的答案？请通过评论详细说明您的反对意见

标签： delphi delphi-xe graphics32

【解决方案1】：

要了解删除不需要的行失败的问题，我们需要查看 Anders Rejbrands 解决方案的工作原理。内存位图bm 是我们存储wanted 行的位图。表单的canvas 充当了一个垫子，我们可以在其中捕捉鼠标动作并向用户提供反馈。在MouseDown 和MouseUp 事件之间（确定想要的起点和终点），我们收到很多MouseMove 事件。对于每个MouseMove，我们首先调用SwapBuffers，它会擦除表单画布中的任何垃圾（从先前的MouseMove 遗留下来的）。然后我们绘制从起点到当前鼠标位置的线。通过将bm 的内容复制（BitBlt）到表单画布来完成擦除。

因为删除不需要的行不起作用，我们需要仔细查看代码中的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 中将 ImgView 替换为 B.BitMap

//    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 不涉及任何内容，因为您希望在图层上进行绘图。

在用户的 cmets 之后编辑...

我确实做了另一项更改。很抱歉忘记提及。

在 FormCreate 中，with B... 下

//    Bitmap.DrawMode := dmBlend;
    Bitmap.DrawMode := dmOpaque;

【讨论】：

好点。因此，在我将 setSize 设置为 bm32 之后，我删除了 swapbuffers 并在任何地方用 swapbuffers32 替换它。但是现在，当我点击 ImgView 时，整个 imgView32 变黑了。如果我评论 BitBlt 调用，则不再有 Canvas 错误并且 Canvas 保持白色，但线条不会被擦除，结果与问题中的图像相同。所以旧线（鼠标移动时）不会被删除......所以我想这就是我需要另一种方法的地方。有什么想法吗？
bm32.Clear(clWhite32) 设置大小后？您需要调用 BitBlt 才能进行擦除。
哇，现在太好了。它现在可以工作（使用原始 BitBlt 调用，其中目标是 ImgView.Canvas）。但是我不相信实际的绘图发生在图层或 ImgView 上。如果我使用图层的画布进行 BitBlt，则没有任何变化，线条仍然保持绘制状态。稍后我会尝试将其他图层添加到 ImgView 以查看我的 drawingLayer 如何影响其他图层，但我认为这不会好...有什么建议吗？
@user1137313 我根据你的新代码更新了我的答案。
很抱歉，在进行更改后，它不再起作用了。从来没有画过线...但是，如果我保留以前的 BitBlt 调用（在 ImgView 画布上绘图，那么它会画线（这次闪烁很多）

【解决方案2】：

在 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 的旋转角度更改为它是什么。将线定位在起点，然后修改长度。反正是想。可能是另一种方法。抱歉，这里缺少代码...

【讨论】：