Delphi Graphics32 how to draw a line with the mouse on a layer

问题

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

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;

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)

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.

What am I doing wrong?

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;

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

回答1:

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.

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.

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.

Edit after update of users code.

In FormCreate, after setting size of bm32, add

  bm32.Clear(clWhite32); // Add this line

and change the following two lines

//    with ImgView.Bitmap do Location := GR32.FloatRect(0, 0, 800, 600);
    B.Location := GR32.FloatRect(0, 0, 800, 600);
//    Scaled := True;
    Scaled := False;

and finally at the end of FormCreate add

  SwapBuffers32;

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

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

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.

Edit after comments from user...

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

In FormCreate, under with B...

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

回答2:

In Firemonkey, I did this using a bitmap to draw the line from 2 points.

Basically, before the line begins (on mouse down, event) , you take a screenshot of the area where you want to draw the line.

Then when the mouse is moving you draw a line on the bitmap copy. Each time before the line is drawn on the bitmap, you replace the bitmap with the original screenshot. Might need tinkering with a bit, but seems to work ok. In the code below the image is aligned to the client of the area where you wish to draw.

Code....

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;

I think there might be another way in fire monkey to achieve a line drawn with the mouse, and that's by dropping a TLine on the form, setting the rotation angle of x,y to 0. When drawing a line create a bounding rectangle from begin, end points, work out the rotation angle of the triangle intersection of the bounding rectangle from begin point (normalised rectangle), and basically change the rotation angle of the TLine to whatever it is. position the line at the start point, then tinker with the length. Thoughts anyway. Might be another method. Sorry for lack of code on this...

来源：https://stackoverflow.com/questions/28510814/delphi-graphics32-how-to-draw-a-line-with-the-mouse-on-a-layer