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