Delphi Graphics32, как нарисовать линию с помощью мыши на слое

Кто-нибудь может помочь мне преобразовать этот замечательный метод динамического рисования линии (рисование линии в стиле Photoshop с помощью 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 не позволяет рисовать)введите описание изображения здесьВ первый раз, когда ошибка появляется на кнопке ButtonClick, затем после того, как я ее ок, начинаю рисовать, она не стирает движущиеся линии (как на картинке выше), затем на мыши снова появляется ошибка холста.

Что я делаю неправильно?

Если я использую 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). Есть идеи?

2 ответа

Решение

Чтобы понять проблему с ошибкой удаления ненужных строк, нам необходимо рассмотреть, как работает решение Anders 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 по-прежнему собирает намеченные строки. Поскольку последний вызов MouseUp относится к SwapBuffers, слой B получит окончательную копию этих строк. ImgView.Bitmap ни для чего не задействован, так как вы хотели иметь рисунок на слое.

Редактировать после комментариев от пользователя...

Я действительно сделал еще одно изменение. Извините, что забыл упомянуть.

В FormCreate, под with B...

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

В 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;

Я думаю, что в Fire Monkey может быть другой способ добиться линии, нарисованной мышью, и это путем перетаскивания TLine на форму, установки угла поворота x,y на 0. При рисовании линии создайте ограничивающий прямоугольник из начала конечные точки определяют угол поворота пересечения треугольника ограничивающего прямоугольника от начальной точки (нормализованный прямоугольник) и, в основном, изменяют угол поворота TLine на любой, какой он есть. поместите линию в начальную точку, затем повозитесь с длиной. Мысли в любом случае. Может быть, другой метод. Извините за отсутствие кода на этом...

Другие вопросы по тегам