问题
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 canvas
of 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