Vẽ Canvas - Làm cách nào để tôi có thể Cải thiện thói quen Vẽ Bản alpha này?

Question

Tôi vẽ lên một bức tranh với Opacity (Alpha Transparency) khả năng như vậy:

var 
    Form1: TForm1; 

    IsDrawing: Boolean; 

implementation 

{$R *.dfm} 

procedure DrawOpacityBrush(ACanvas: TCanvas; X, Y: Integer; AColor: TColor; ASize: Integer; Opacity: Byte); 
var 
    Bmp: TBitmap; 
    I, J: Integer; 
    Pixels: PRGBQuad; 
    ColorRgb: Integer; 
    ColorR, ColorG, ColorB: Byte; 
begin 
    Bmp := TBitmap.Create; 
    try 
    Bmp.PixelFormat := pf32Bit; // needed for an alpha channel 
    Bmp.SetSize(ASize, ASize); 

    with Bmp.Canvas do 
    begin 
     Brush.Color := clFuchsia; // background color to mask out 
     ColorRgb := ColorToRGB(Brush.Color); 
     FillRect(Rect(0, 0, ASize, ASize)); 
     Pen.Color := AColor; 
     Pen.Style := psSolid; 
     Pen.Width := ASize; 
     MoveTo(ASize div 2, ASize div 2); 
     LineTo(ASize div 2, ASize div 2); 
    end; 

    ColorR := GetRValue(ColorRgb); 
    ColorG := GetGValue(ColorRgb); 
    ColorB := GetBValue(ColorRgb); 

    for I := 0 to Bmp.Height-1 do 
    begin 
     Pixels := PRGBQuad(Bmp.ScanLine[I]); 
     for J := 0 to Bmp.Width-1 do 
     begin 
     with Pixels^ do 
     begin 
      if (rgbRed = ColorR) and (rgbGreen = ColorG) and (rgbBlue = ColorB) then 
      rgbReserved := 0 
      else 
      rgbReserved := Opacity; 
      // must pre-multiply the pixel with its alpha channel before drawing 
      rgbRed := (rgbRed * rgbReserved) div $FF; 
      rgbGreen := (rgbGreen * rgbReserved) div $FF; 
      rgbBlue := (rgbBlue * rgbReserved) div $FF; 
     end; 
     Inc(Pixels); 
     end; 
    end; 

    ACanvas.Draw(X, Y, Bmp, 255); 
    finally 
    Bmp.Free; 
    end; 
end; 

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; 
    Shift: TShiftState; X, Y: Integer); 
begin 
    case Button of 
    mbLeft: 
    begin 
     IsDrawing := True; 
     DrawOpacityBrush(Form1.Canvas, X, Y, clRed, 50, 85); 
    end; 
    end; 
end; 

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, 
    Y: Integer); 
begin 
    if (GetAsyncKeyState(VK_LBUTTON) <> 0) and 
    (IsDrawing) then 
    begin 
    DrawOpacityBrush(Form1.Canvas, X, Y, clRed, 50, 85); 
    end; 
end; 

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; 
    Shift: TShiftState; X, Y: Integer); 
begin 
    IsDrawing := False; 
end; 

Các vẽ DrawOpacityBrush() thủ tục được cập nhật bởi Remy Lebeau về một câu hỏi trước Gần đây tôi hỏi: How to paint on a Canvas with Transparency and Opacity?

Trong khi công trình này, kết quả là không thỏa đáng với những gì tôi bây giờ cần.

Hiện tại, mỗi khi thủ tục DrawOpacityBrush() được gọi trong MouseMove, nó vẫn tiếp tục vẽ hình dạng hình elip cọ vẽ. Điều này là xấu bởi vì tùy thuộc vào cách nhanh chóng bạn di chuyển chuột xung quanh canvas, đầu ra không như mong đợi.

Những hình ảnh mẫu nên minh họa điều này tốt hơn hy vọng:

- Các bàn chải màu đỏ đầu tiên tôi chuyển chuột khá nhanh chóng từ dưới cùng của vải đến đỉnh.
- Bàn chải màu đỏ thứ hai tôi di chuyển chậm hơn rất nhiều.

Như bạn có thể thấy độ mờ được vẽ chính xác, ngoại trừ vòng tròn tiếp tục vẽ liên tục.

Những gì tôi muốn nó để làm thay thế là:

(1) Sơn với một dòng opacity xung quanh hình elip.

(2) Có tùy chọn để ngăn chặn bất kỳ hình elip nào được vẽ.

hình ảnh mẫu giả này nên đưa ra một ý tưởng về cách tôi muốn nó được rút ra:

3 dòng bàn chải màu tím chứng tỏ tùy chọn (1).

Để đạt được tùy chọn (2) các vòng tròn bên trong vạch kẻ cọ không nên ở đó.

Điều này sau đó sẽ cho phép bạn dành thời gian khi vẽ, không điên cuồng di chuyển chuột xung quanh canvas với hy vọng nhận được kết quả bạn cần. Chỉ khi bạn quyết định quay trở lại nét cọ bạn vừa tạo thì độ mờ cho vùng đó trở nên tối hơn, vv ..

Làm cách nào để có thể đạt được các loại hiệu ứng vẽ này?

Tôi muốn có thể vẽ lên một TImage vì đó là những gì tôi hiện đang làm, vì vậy việc vượt qua TCanvas như một tham số trong một hàm hoặc thủ tục sẽ là lý tưởng. Tôi cũng sẽ sử dụng các sự kiện MouseDown, MouseMove và MouseUp cho bản vẽ của tôi.

Đây là sản phẩm tôi nhận được bằng cách sử dụng phương pháp được cung cấp bởi NGLN:

Opacity dường như được áp dụng cho các hình ảnh quá, nó chỉ nên là dòng poly.

Answer 1

Tại sao không chỉ vẽ một đường polyline?

unit Unit1; 

interface 

uses 
    Windows, Classes, Graphics, Controls, Forms, ExtCtrls; 

type 
    TPolyLine = record 
    Count: Integer; 
    Points: array of TPoint; 
    end; 

    TPolyLines = array of TPolyLine; 

    TForm1 = class(TForm) 
    PaintBox: TPaintBox; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure FormResize(Sender: TObject); 
    procedure PaintBoxMouseDown(Sender: TObject; Button: TMouseButton; 
     Shift: TShiftState; X, Y: Integer); 
    procedure PaintBoxMouseMove(Sender: TObject; Shift: TShiftState; X, 
     Y: Integer); 
    procedure PaintBoxPaint(Sender: TObject); 
    private 
    FBlendFunc: BLENDFUNCTION; 
    FBmp: TBitmap; 
    FPolyLineCount: Integer; 
    FPolyLines: TPolyLines; 
    procedure AddPoint(APoint: TPoint); 
    function LastPoint: TPoint; 
    procedure NewPolyLine; 
    end; 

var 
    Form1: TForm1; 

implementation 

{$R *.dfm} 

procedure TForm1.AddPoint(APoint: TPoint); 
begin 
    with FPolyLines[FPolyLineCount - 1] do 
    begin 
    if Length(Points) = Count then 
     SetLength(Points, Count + 64); 
    Points[Count] := APoint; 
    Inc(Count); 
    end; 
end; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
    FBmp := TBitmap.Create; 
    FBmp.Canvas.Brush.Color := clWhite; 
    FBmp.Canvas.Pen.Width := 30; 
    FBmp.Canvas.Pen.Color := clRed; 
    FBlendFunc.BlendOp := AC_SRC_OVER; 
    FBlendFunc.SourceConstantAlpha := 80; 
    DoubleBuffered := True; 
end; 

procedure TForm1.FormDestroy(Sender: TObject); 
begin 
    FBmp.Free; 
end; 

procedure TForm1.FormResize(Sender: TObject); 
begin 
    FBmp.Width := PaintBox.Width; 
    FBmp.Height := PaintBox.Height; 
end; 

function TForm1.LastPoint: TPoint; 
begin 
    with FPolyLines[FPolyLineCount - 1] do 
    Result := Points[Count - 1]; 
end; 

procedure TForm1.NewPolyLine; 
begin 
    Inc(FPolyLineCount); 
    SetLength(FPolyLines, FPolyLineCount); 
    FPolyLines[FPolyLineCount - 1].Count := 0; 
end; 

procedure TForm1.PaintBoxMouseDown(Sender: TObject; Button: TMouseButton; 
    Shift: TShiftState; X, Y: Integer); 
begin 
    if ssLeft in Shift then 
    begin 
    NewPolyLine; 
    AddPoint(Point(X, Y)); 
    PaintBox.Invalidate; 
    end; 
end; 

procedure TForm1.PaintBoxMouseMove(Sender: TObject; Shift: TShiftState; X, 
    Y: Integer); 
begin 
    if ssLeft in Shift then 
    if Sqr(LastPoint.X - X) + Sqr(LastPoint.Y - Y) > 30 then 
    begin 
     AddPoint(Point(X, Y)); 
     PaintBox.Invalidate; 
    end; 
end; 

procedure TForm1.PaintBoxPaint(Sender: TObject); 
var 
    R: TRect; 
    I: Integer; 
begin 
    R := PaintBox.ClientRect; 
    FBmp.Canvas.FillRect(R); 
    for I := 0 to FPolyLineCount - 1 do 
    with FPolyLines[I] do 
     FBmp.Canvas.Polyline(Copy(Points, 0, Count)); 
    Windows.AlphaBlend(PaintBox.Canvas.Handle, 0, 0, R.Right, R.Bottom, 
    FBmp.Canvas.Handle, 0, 0, R.Right, R.Bottom, FBlendFunc); 
end; 

end. 

Bức tranh thứ hai cho thấy làm thế nào để kết hợp điều này với một nền và được nhận với việc bổ sung nhỏ sau đây để các mã, trong khi FGraphic là một runtime nạp hình ảnh:

procedure TForm1.PaintBoxPaint(Sender: TObject); 
var 
    R: TRect; 
    I: Integer; 
begin 
    R := PaintBox.ClientRect; 
    FBmp.Canvas.FillRect(R); 
    for I := 0 to FPolyLineCount - 1 do 
    with FPolyLines[I] do 
     FBmp.Canvas.Polyline(Copy(Points, 0, Count)); 
    PaintBox.Canvas.StretchDraw(R, FGraphic); 
    Windows.AlphaBlend(PaintBox.Canvas.Handle, 0, 0, R.Right, R.Bottom, 
    FBmp.Canvas.Handle, 0, 0, R.Right, R.Bottom, FBlendFunc); 
end; 

Hoặc, để kết hợp công việc đã vẽ (như Image) của bạn, hãy sao chép canvas của nó vào PaintBox:

procedure TForm1.PaintBoxPaint(Sender: TObject); 
var 
    R: TRect; 
    I: Integer; 
begin 
    R := PaintBox.ClientRect; 
    FBmp.Canvas.FillRect(R); 
    FBmp.Canvas.Polyline(Copy(FPoly, 0, FCount)); 
    for I := 0 to FPolyLineCount - 1 do 
    with FPolyLines[I] do 
     FBmp.Canvas.Polyline(Copy(Points, 0, Count)); 
    Windows.AlphaBlend(PaintBox.Canvas.Handle, 0, 0, R.Right, R.Bottom, 
    FBmp.Canvas.Handle, 0, 0, R.Right, R.Bottom, FBlendFunc); 
end; 

Nhưng cũng như David đã đề cập trong nhận xét, tôi cũng khuyên bạn nên vẽ mọi thứ trên PaintBox: đó là ý nghĩa của nó.