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

问题描述 投票：1回答：2

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

delphi delphi-xe graphics32
2个回答
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;
0
投票

在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.当绘制线条时，从begin创建一个边界矩形，终点，计算出从开始点（标准化矩形）开始的边界矩形的三角形交点的旋转角度，并基本上将TLine的旋转角度改变为它的任何位置。将线定位在起始点，然后修改长度。无论如何想。可能是另一种方法。很抱歉这个代码不足......

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.