文章/答案/技术大牛

发布

社区首页 >问答首页 >德尔福Graphics32相对鼠标位置(到图层)

问德尔福Graphics32相对鼠标位置(到图层)
EN

Stack Overflow用户

提问于 2015-02-16 20:48:32

回答 2查看 1.6K关注 0票数 2

我有一个ImgView32，它锚定在所有形式的空白处。形式是最大化的。

ImgView的位图不是固定的(可以是不同大小的)。

我试图使用以下问题的代码在透明层上画一条线：Drawing lines on layer

现在的问题是，使用精确的代码，我只能在左上角绘制，就像在这个图像中：

正如您所观察到的，这些线只能在左上角绘制。如果我试图为起点和终点增加一些价值，整个事情就会变得疯狂。因此，我必须找到一种方法，以这样的方式翻译这些点，这样用户就只能在中间的rect (在图像中可见)内绘制。

我没有主意了。

请帮帮忙

以下是整个小组：

unit MainU;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,GR32, GR32_Image, GR32_Layers, GR32_Backends, GR32_PNG, StdCtrls,
  ExtCtrls;

type
  TForm5 = class(TForm)
    ImgView: TImgView32;
    Button1: TButton;
    Memo: TMemo;
    Edit3: TEdit;
    Button2: TButton;
    RadioGroup1: TRadioGroup;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
      StageNum: Cardinal);
    procedure ImgViewResize(Sender: TObject);
 private
    { Private declarations }
    FStartPoint, FEndPoint: TPoint;
    FDrawingLine: boolean;
    bm32: TBitmap32;
    BL : TBitmapLayer;
    FSelection: TPositionedLayer;
 public
    { Public declarations }
    procedure AddLineToLayer;
    procedure AddCircleToLayer;
    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;

    Procedure SelectGraficLayer(idu:string);
    procedure AddTransparentPNGlayer;

  end;

var
  Form5: TForm5;

implementation

{$R *.dfm}

var
  imwidth: integer;
  imheight: integer;
  OffsX, OffsY: Integer;

const
  penwidth = 3;
  pencolor = clBlue;  // Needs to be a VCL color!

procedure TForm5.AddLineToLayer;
begin
  bm32.Canvas.Pen.Color := pencolor;
  bm32.Canvas.Pen.Width := penwidth;
  bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
  bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;

procedure TForm5.FormCreate(Sender: TObject);
var
  P: TPoint;
  W, H: Single;
begin
  imwidth := Form5.ImgView.Width;
  imheight := Form5.ImgView.Height;

  with ImgView.PaintStages[0]^ do
  begin
    if Stage = PST_CLEAR_BACKGND then Stage := PST_CUSTOM;
  end;

  bm32 := TBitmap32.Create;
  bm32.DrawMode := dmTransparent;
  bm32.SetSize(imwidth,imheight);
  bm32.Canvas.Pen.Width := penwidth;
  bm32.Canvas.Pen.Color := pencolor;

  with ImgView do
  begin
    Selection := nil;
    Layers.Clear;
    Scale := 1;
    Scaled := True;
    Bitmap.DrawMode := dmTransparent;
    Bitmap.SetSize(imwidth, imheight);
    Bitmap.Canvas.Pen.Width := 4;//penwidth;
    Bitmap.Canvas.Pen.Color := clBlue;
    Bitmap.Canvas.FrameRect(Rect(20, 20, imwidth-20, imheight-20));
    Bitmap.Canvas.TextOut(15, 32, 'ImgView');
  end;

  AddTransparentPNGLayer;

  BL := TBitmapLayer.Create(ImgView.Layers);
  try
    BL.Bitmap.DrawMode := dmTransparent;
    BL.Bitmap.SetSize(imwidth,imheight);
    BL.Bitmap.Canvas.Pen.Width := penwidth;
    BL.Bitmap.Canvas.Pen.Color := pencolor;
    BL.Location := GR32.FloatRect(0, 0, imwidth, imheight);
    BL.Scaled := False;
    BL.OnMouseDown := LayerMouseDown;
    BL.OnMouseUp := LayerMouseUp;
    BL.OnMouseMove := LayerMouseMove;
    BL.OnPaint := LayerOnPaint;
  except
  Edit3.Text:=IntToStr(BL.Index);
    BL.Free;
    raise;
  end;

  FDrawingLine := false;
  SwapBuffers32;
end;

procedure TForm5.FormDestroy(Sender: TObject);
begin
  bm32.Free;
  BL.Free;
end;

procedure TForm5.ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
  StageNum: Cardinal);
const            //0..1
  Colors: array [Boolean] of TColor32 = ($FFFFFFFF, $FFB0B0B0);
var
  R: TRect;
  I, J: Integer;
  OddY: Integer;
  TilesHorz, TilesVert: Integer;
  TileX, TileY: Integer;
  TileHeight, TileWidth: Integer;
begin
  TileHeight := 13;
  TileWidth := 13;

  TilesHorz := Buffer.Width div TileWidth;
  TilesVert := Buffer.Height div TileHeight;
  TileY := 0;

  for J := 0 to TilesVert do
  begin
    TileX := 0;
    OddY := J and $1;
    for I := 0 to TilesHorz do
    begin
      R.Left := TileX;
      R.Top := TileY;
      R.Right := TileX + TileWidth;
      R.Bottom := TileY + TileHeight;
      Buffer.FillRectS(R, Colors[I and $1 = OddY]);
      Inc(TileX, TileWidth);
    end;
    Inc(TileY, TileHeight);
  end;
end;

procedure TForm5.ImgViewResize(Sender: TObject);
begin
  OffsX := (ImgView.ClientWidth - imwidth) div 2;
  OffsY := (ImgView.ClientHeight - imheight) div 2;
  BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;

procedure TForm5.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FStartPoint := Point(X-OffsX, Y-OffsY);
  FDrawingLine := true;
end;

procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);
begin
  if FDrawingLine then
  begin
    SwapBuffers32;
      BL.Bitmap.Canvas.Pen.Color := pencolor;
      BL.Bitmap.Canvas.MoveTo(FStartPoint.X-OffsX, FStartPoint.Y-OffsY);
      BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
  end;
end;

procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDrawingLine := false;
  FEndPoint := Point(X-OffsX, Y-OffsY);
  AddLineToLayer;
  SwapBuffers32;
end;

procedure TForm5.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
  SwapBuffers32;
end;

procedure TForm5.SetSelection(Value: TPositionedLayer);
begin
  if Value <> FSelection then
  begin
    FSelection := Value;
  end;
end;

procedure TForm5.SwapBuffers32;
begin
    TransparentBlt(
      BL.Bitmap.Canvas.Handle, 0, 0, BL.Bitmap.Width, BL.Bitmap.Height,
      bm32.Canvas.Handle, 0, 0, bm32.Width, bm32.Height, clWhite);
end;

procedure TForm5.AddTransparentPNGlayer;
var
  mypng:TPortableNetworkGraphic32;
  B : TBitmapLayer;
  P: TPoint;
  W, H: Single;
begin
      try
        mypng := TPortableNetworkGraphic32.Create;
        mypng.LoadFromFile('C:\Location\Of\ATransparentPNGFile.png');
        B := TBitmapLayer.Create(ImgView.Layers);
        with B do
        try
          mypng.AssignTo(B.Bitmap);
          Bitmap.DrawMode := dmBlend;
          with ImgView.GetViewportRect do
            P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
          W := Bitmap.Width * 0.5;
          H := Bitmap.Height * 0.5;
          Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
          Scaled := True;
          OnMouseDown := LayerMouseDown;
        except
          Free;
          raise;
        end;
        Selection := B;
        Edit3.Text:=IntToStr(B.Index);
      finally
        mypng.Free;
      end;
end;

end.

我做错了什么？请测试上面的单元，看看我的意思。请记住添加一个ImgView并将其锚定到所有的边距，然后在运行时，最大化表单并尝试绘制线.

编辑

在上面的绿色图像中，有一个正方形，更像是中间的一个正方形(不是很明显)，但是如果你仔细看的话，你可以看到它。

由于我的问题可能被误解了，请看下面的图片

我只需要能够在ImgView中间的白色矩形(位图)中绘制。我不知道如何更好地解释。

使矩形/位图与ImgView完全匹配并不是我的解决方案，因为这不是我的项目的重点。

看看Paint.net，想象一下我的项目也是这样的(只是它并不那么复杂)。但是原则是一样的:当您开始一个新项目时，您决定文档/图像的大小，然后将不同的图像作为层添加，缩放和旋转它们，现在我希望允许用户在一个特殊层(绘图层)内绘制线条，但是所有事情都发生在文档大小的边界内。例如，在上面的图像中，文档的大小是A5 (100 for )，比例为83%。

因此，我的问题是，我不能允许用户在白色矩形(屏幕中部)之外画线。所以他们的线可以从这些边界开始到那里结束。

我知道我的测试单元不是很干净。我粘贴了一些在主项目中使用的函数，并很快从它们中删除了一些与本例无关的部分。AddTransparentPng过程只允许向ImgView添加透明图像的测试，这样我就可以测试绘图层是否覆盖了另一个可能的延迟器。

(缩放属性属于图层(B)，它位于“with B”语句下。我删除了With‘ImgView.Bitmap. Location’语句，这样就不会再困扰您了:)

无论如何，请不要注意不影响线条绘制的代码。这段代码是需要注意的。

如果我将图层的缩放值设置为true ()，那么它会把所有事情都搞砸，如下面的图像所示：

我仍然需要使用偏移量，但有点不同。

谢谢

delphi

delphi-xe

graphics32

回答 2

Stack Overflow用户

回答已采纳

发布于 2015-02-17 06:32:09

错误一

在LayerMouseMove()中，从BL.Bitmap.Canvas.MoveTo()中的FStartPoint中减去OffsX和OffsY。FStartPoint已经在LayerMouseDown()中进行了调整。我告诉过你，“在三个鼠标过程中，调整X和Y参数，只会变成X和you。”注：arguments only这里更正了LayerMouseMove()：

procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if FDrawingLine then
  begin
    SwapBuffers32;
      BL.Bitmap.Canvas.Pen.Color := pencolor;
//      BL.Bitmap.Canvas.MoveTo(FStartPoint.X-OffsX, FStartPoint.Y-OffsY);
      BL.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
      BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
  end;
end;

误差二

我还告诉您将if FDrawingLine then ...条件添加到LayerMouseUp()中，以避免当鼠标向下发生在层外，而鼠标向上发生在内部时，以避免出现伪行。修正后的LayerMouseUp()：

procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if FDrawingLine then
  begin
    FDrawingLine := false;
    FEndPoint := Point(X-OffsX, Y-OffsY);
    AddLineToLayer;
    SwapBuffers32;
  end;
end;

误差三

发布的代码不像您的第一个图像显示的那样执行。这个图像看起来比ImgViewResize()中的行ImgViewResize()要好。也许你这么做是因为Error one。不管怎么说，使用下面的ImgViewResize和上面的其他更正，我得到了如下图片所示的结果。

procedure TForm5.ImgViewResize(Sender: TObject);
begin
  // centering the drawing area
  OffsX := (ImgView.ClientWidth - imwidth) div 2;
  OffsY := (ImgView.ClientHeight - imheight) div 2;
  BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;

变量imwidth和imheight定义绘图区域的大小。如果您更改了这些参数，则需要重新计算OffsX和OffsY，还需要调整后台缓冲区bm32的大小。

角落中的线条表示窗口中间的绘图区域(由宽度和高度定义)的范围。当窗口最大化时，它也保持不变。

票数 4

Stack Overflow用户

发布于 2015-02-17 06:27:46

好吧，我解决了。以下是最终(相关)代码：

procedure TForm5.ImgViewResize(Sender: TObject);
begin
  OffsX := (ImgView.ClientWidth - imwidth) div 2;
  OffsY := (ImgView.ClientHeight - imheight) div 2;
  BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;

procedure TForm5.SwapBuffers32;
begin
    TransparentBlt(
      BL.Bitmap.Canvas.Handle, 0, 0, BL.Bitmap.Width, BL.Bitmap.Height,
      bm32.Canvas.Handle, 0, 0, bm32.Width, bm32.Height, clWhite);
end;


procedure TForm5.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FStartPoint := Point(X-OffsX, Y-OffsY);
  FDrawingLine := true;
end;

procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);
begin
  if FDrawingLine then
  begin
    SwapBuffers32;
      BL.Bitmap.Canvas.Pen.Color := pencolor;
      BL.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
      BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
  end;
end;


procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDrawingLine := false;
  FEndPoint := Point(X-OffsX, Y-OffsY);
  AddLineToLayer;
  SwapBuffers32;
end;

procedure TForm5.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
  SwapBuffers32;
end;

procedure TForm5.AddLineToLayer;
begin
  bm32.Canvas.Pen.Color := pencolor;
  bm32.Canvas.Pen.Width := penwidth;
  bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
  bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;

有了这段代码，一切都如愿以偿。线的绘制只能在边界内进行。

谢谢

票数 0

页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持

原文链接：

https://stackoverflow.com/questions/28550072

复制

相似问题

问德尔福Graphics32相对鼠标位置(到图层)
EN

回答 2

Stack Overflow用户

Stack Overflow用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问德尔福Graphics32相对鼠标位置(到图层)EN

回答 2

Stack Overflow用户

Stack Overflow用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问德尔福Graphics32相对鼠标位置(到图层)
EN