Delphi Graphics32如何在层上用鼠标画一条线 [英] Delphi Graphics32 how to draw a line with the mouse on a layer

问题描述

有人可以帮我转换这种动态绘制线条的好方法吗? (带有delphi的Photoshop样式绘制线)到Graphics32?

Can anybody help me convert this great method of dynamically drawing a line (Photoshop style drawing line with delphi) to Graphics32?

我的意思是，我想拥有一个ImgView，在其中添加一个新层，然后在该层而不是窗体的画布上执行这些方法.

I mean, I want to have a ImgView, add a new layer to it, then perform these methods on the layer instead of the form's canvas.

所以我认为，我的代码应如下所示:

So I assume, my code should look like this:

 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;

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

I assume this code because those are the events used in the regular canvas drawing method from the link, but the rest of the methods do not work like they should

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控件，并且窗体上还有一个按钮)

So it does not work. Nothing happens. Can anybody assist me in making this work like in the normal canvas drawing? I want to make this happen for just one layer, the layer I create with Button1Click... (ImgView is a ImgView32 control placed on the form, and there is also a button on the form)

结果看起来像这样(错误说Canvas不允许绘图) 错误第一次出现在onButtonClick上，然后单击确定后，我开始绘图，它不会擦除移动线(就像上图中一样)，然后onMouseUp再次出现Canvas错误.

the result looks like this (with error saying that Canvas does not allow drawing) First time the error appears onButtonClick, then after I Ok it, I start drawing, it does not erase the moving lines (just like in the image above), then onMouseUp the Canvas error appears again.

我在做什么错了?

如果我使用SwapBuffers32，则不会绘制任何内容，并且会不断显示画布错误.

If I use SwapBuffers32, nothing gets drawn , and canvas errors keep showing up.

编辑: 我做了一些更改，只是为了尝试使其在汤姆·布鲁伯格的建议之后起作用，最终我得到了以下代码:

EDIT: I made a few changes just to try making it work after Tom Brunberg's suggestions and I ended up with this code:

 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)中.有什么想法吗?

Now, no more Canvas errors, but the mouse-move lines stay drawn... The solution must be in the BitBlt function (swapbuffers32). Any ideas?

推荐答案

要了解无法删除不需要的行的问题，我们需要查看Anders Rejbrands解决方案的工作方式. 内存中的位图bm是我们存储所需行的位图.表单的canvas充当垫子，我们可以在其中捕获鼠标动作并向用户提供反馈.在MouseDown和MouseUp事件(确定所需的起点和终点)之间，我们收到很多MouseMove事件.对于每个MouseMove，我们首先调用SwapBuffers，该SwapBuffers从表单画布中擦除任何垃圾(以前的MouseMove的剩余物).然后，我们从起点到当前鼠标位置画一条线.通过将bm的内容复制(BitBlt)到表单画布中来完成擦除.

To understand the problem with the failing erasure of unwanted lines, we need to review how Anders Rejbrands solution works. The in-memory bitmap bm is the bitmap to which we store wanted lines. The canvasof the form acts as a pad where we catch the mouse actions and give feedback to the user. Between MouseDown and MouseUp events (which determine the wanted start point and end point) we receive a lot of MouseMove events. For each MouseMove we first call SwapBuffers which erases any rubbish (leftover from previous MouseMove) from the forms canvas. Then we draw the line from the start point to current mouse position. The erasure is done by copying (BitBlt) the content of bm to the forms canvas.

由于无法删除不需要的行，因此我们需要仔细查看代码中的bm32.您在FormCreate中创建它，但从未给它指定大小！这就是问题所在.在SwapBuffers32中没有要复制的内容.

Because the erasure of unwanted lines doesn't work, we need to look closer at bm32 in your code. You create it in FormCreate but you never give it a size! And that is the problem. There's nothing to copy from in SwapBuffers32.

此外，由于位图没有大小，因此不允许绘制.因此出现错误消息.

Also, because the bitmap doesn't have a size, it doesn't allow drawing. Thus the error message.

SwapBuffer的另一个版本引用了bm变量，该变量未在其他任何代码中显示，因此我根本无法对此进行评论.

The other version of SwapBuffer refers to a bm variable, which is not shown in any other code, so I can't really comment on that at all.

在更新用户代码后进行编辑.

在FormCreate中，设置bm32的大小后，添加

In FormCreate, after setting size of bm32, add

  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的末尾添加

and finally at the end of FormCreate add

  SwapBuffers32;

在LayerMouseMove中，将ImgView替换为B.BitMap

In LayerMouseMove replace ImgView with 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中，使用B.Bitmap的属性替换ClientWidth和ClienHeight

and in SwapBuffers32 replace ClientWidth and ClienHeight with properties of 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不涉及任何内容，因为您希望在图层上绘制图形.

These changes works for me so that bm32 still collects intended lines. Since the last call of MouseUp is to SwapBuffers, the B layer will get a final copy of those lines. The ImgView.Bitmap is not involved for anything as you wanted to have the drawing on the layer.

在用户评论后编辑...

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

There is indeed one more change I did. Sorry for forgetting to mention.

在FormCreate中的with B...

In FormCreate, under with B...

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

这篇关于Delphi Graphics32如何在层上用鼠标画一条线的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！