Question

有人可以帮我转换动态绘制线(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不允许绘图） enter image description here 第一次错误出现在按钮上，然后在我确定之后，我开始绘图，它不会删除移动的线条（就像上图中一样），然后在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）。有什么想法吗？

Answer 1

要了解无法删除不需要的行的问题，我们需要查看Anders Rejbrands解决方案的工作原理。内存中的位图bm是我们存储想要的行的位图。表单的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中，用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;

Answer 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;

我认为火猴可能有另一种方法来实现用鼠标绘制的线条，并且通过在表格上放置TLine，将x，y的旋转角度设置为0。 line从begin，end points创建一个边界矩形，计算出从开始点（标准化矩形）开始的边界矩形的三角形交点的旋转角度，并基本上将TLine的旋转角度更改为它是什么。将线定位在起始点，然后修改长度。无论如何想。可能是另一种方法。很抱歉这个代码不足......

Delphi Graphics32如何在图层上用鼠标绘制线条

2 个答案: