1

谁能帮我将这种动态绘制线条的好方法（使用delphi的Photoshop风格绘图线）转换为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不允许绘图） 在此处输入图像描述 第一次出现错误onButtonClick，然后在I Ok it之后，我开始绘图，它不会擦除移动线（就像上图一样），然后onMouseUp 再次出现 Canvas 错误。

我究竟做错了什么？

如果我使用 SwapBuffers32，则不会绘制任何内容，并且画布错误会不断出现。

编辑：我做了一些改变只是为了尝试在汤姆布伦伯格的建议之后让它工作，我最终得到了这个代码：

 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) 中。有任何想法吗？

4

2 回答 2

1

要了解删除不需要的行失败的问题，我们需要回顾一下 Anders Rejbrands 解决方案的工作原理。内存位图bm是我们存储所需行的位图。表单的canvas作用是我们捕捉鼠标动作并向用户提供反馈的垫子。在MouseDown和MouseUp事件之间（确定想要的起点和终点）我们会收到很多MouseMove事件。对于MouseMove我们首先调用的每一个SwapBuffers，它都会从表单画布中删除任何垃圾（从先前的 MouseMove 中删除）。然后我们绘制从起点到当前鼠标位置的线。通过将 (BitBlt) 的内容复制bm到表单画布来完成擦除。

因为删除不需要的行不起作用，我们需要仔细查看bm32您的代码。您在 FormCreate 中创建它，但您从不给它一个大小！这就是问题所在。没有什么可以从 in 复制的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 中，将 ImgView 替换为 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 中将 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;
于 2015-02-15T09:33:23.490 回答
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。当绘制一条线时，从开始创建一个边界矩形，端点，从起点（归一化矩形）算出边界矩形的三角形交点的旋转角度，并基本上将 TLine 的旋转角度更改为任何它。将线定位在起点，然后修改长度。反正是想。可能是另一种方法。抱歉，缺少这方面的代码...

于 2018-01-01T02:16:50.383 回答