Delphi的Graphics32如何绘制用鼠标线的层上(Delphi Graphics32 how

2019-10-21 21:10发布

站内文章 / 前端开发
32 0 0

任何人可以帮助我转换的动态画线这个伟大的方法（用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控制，而且还有在窗体上按钮）

结果看起来是这样的（错误说画布不允许绘图） 第一时间出现在错误onButtonClick，然后我好了，我开始绘制后，它不会抹去的动线（就像上面的图片中），然后onMouseUp画布错误再次出现。

我究竟做错了什么？

如果我使用SwapBuffers32，没有获取绘制和画布错误不断显示出来。

编辑 ：我做了一些改动只是为了尝试使它后汤姆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;

现在，没有更多的帆布错误，但移动鼠标线保持抽...该解决方案必须在BitBlt函数（swapbuffers32）。 有任何想法吗？

Answer 1:

要了解有不必要的线条失败删除的问题，我们需要回顾安德斯Rejbrands解决方案是如何工作的。 在内存中的位图bm是，这是我们想要存储的线位。 该canvas的形式作为我们捕鼠行动，并反馈给用户一个垫。 之间MouseDown和MouseUp事件（确定想要的开始点和结束点），我们收到了很多MouseMove事件。 对于每一个MouseMove我们首先调用SwapBuffers这将擦除画布形式任何垃圾（剩余从以前的MouseMove）。 然后，我们借鉴起点到当前鼠标位置的行。 擦除是通过拷贝（的BitBlt）的内容做bm的形式画布。

由于不需要线擦除不能正常工作，我们需要看仔细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取代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仍会收集预期线。 由于的Mo​​useUp的最后一次通话是SwapBuffers，B层将获得这些行的最后文本。 该ImgView.Bitmap不参与任何东西，你想有层上绘图。

从用户的意见后，编辑...

的确有一个更改变我做到了。 对不起，忘了提。

在FORMCREATE，下with B... 

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


Answer 2:

在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的旋转角度，以不管它是。 定位在起点的线，则与长度修补。 思考反正。 可能是另一种方法。 对不起，在这种缺乏代码...



文章来源: Delphi Graphics32 how to draw a line with the mouse on a layer
标签： delphi delphi-xe graphics32
举报

收藏的人(0)

Ta的文章 更多文章
登录 后发表评论
0条评论
还没有人评论过~