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

Question

Может кто-нибудь помочь мне преобразовать этот отличный метод динамического рисования строки (Photoshop style drawing line with 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; 

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

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

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

Если я использую SwapBuffers32, ничего не нарисовано, и ошибки холста продолжают появляться.

EDIT: Я сделал несколько изменений, просто чтобы попробовать заставить его работать после того, как предложения Тома 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; 

Теперь, не больше ошибок Canvas, но мышь- перемещение строк остается нарисованным ... Решение должно быть в функции BitBlt (swapbuffers32). Есть идеи?

Answer 1

Чтобы понять проблему с неудачным стиранием нежелательных строк, нам необходимо рассмотреть, как работает решение 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 не участвует ни в чем, поскольку вы хотели иметь рисунок на слое.

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

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

В 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 что бы это ни было. расположите линию в начальной точке, затем поместите ее с длиной. Мысли все равно. Возможно, это другой метод. Извините за отсутствие кода на этом ...