Относительная позиция мыши Delphi Graphics32 (к слою)

Question

У меня есть ImgView32, который привязан ко всем полям формы. Форма максимально увеличена.

Растровое изображение ImgView не является фиксированным (оно может быть разных размеров)

Я пытаюсь нарисовать линию на прозрачном слое, используя код из этого вопроса: Рисование линий на слое

Теперь проблема в том, что, используя этот точный код, я могу рисовать только в верхнем левом углу, как на этом изображении:

Как видите, линии можно нарисовать только в левом верхнем углу. Если я попытаюсь добавить какую-то ценность к начальной и конечной точкам, все это сойдет с ума. Поэтому я должен найти способ перевести точки таким образом, чтобы пользователь мог рисовать только внутри центрального прямоугольника (видимого на изображении)

У меня нет идей.

Пожалуйста помоги

Вот весь блок:

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 точек на дюйм) масштабируется до 83%.

Поэтому моя проблема в том, что я не могу позволить пользователям рисовать линии за пределами белого прямоугольника (середина экрана). Таким образом, их линии могут начинаться в этих границах и заканчиваться там.

Я знаю, что мой тестовый блок не идеально чистый. Я вставил некоторые функции, используемые в основном проекте, и быстро удалил из них некоторые части, которые не относятся к этому примеру. Процедура AddTransparentPng предназначена только для того, чтобы разрешить тестирование добавления прозрачного изображения в ImgView, чтобы я мог проверить, не покрывает ли слой рисования другой возможный слой.

(Свойство Scaled принадлежит слою (B), который находится под оператором 'with B.' Я удалил оператор With 'ImgView.Bitmap... Location', чтобы он больше не беспокоил вас:))

В любом случае, пожалуйста, не обращайте внимания на код, который не влияет на рисование линий. Этот код - то, что требует внимания.

РЕДАКТИРОВАТЬ Если я установил масштабированный слой в значение true (Scaled:=true), то он все испортит, как на изображении ниже:

Я все еще должен использовать смещения, но немного по-другому

Спасибо

Answer 1

Ошибка первая

В LayerMouseMove() вычитаете OffsX и OffsY из FStartPoint в BL.Bitmap.Canvas.MoveTo(). FStartPoint уже настроен в LayerMouseDown(). Я сказал вам: "В трех мышиных проках отрегулируйте аргументы X и Y только для того, чтобы они стали X-OffsX и Y-OffsY". Заметка 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;

Ошибка три

Размещенный код не работает, как показывает ваше первое изображение. Изображение выглядит так, как если бы вы закомментировали строку BL.Location := ... в 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 также.

Линии в углах указывают размер области рисования (определяется по ширине и высоте) в середине окна. То же самое остается, когда окно развернуто.

Answer 2

Хорошо, я решил это. Вот окончательный (соответствующий) код:

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;

С этим кодом все работает как положено. Рисование линий может происходить только в пределах границ.

Спасибо