Leinwandzeichnung - Wie kann ich diese Alpha-Zeichnungsroutine verbessern?

Question

Ich zeichne auf eine Leinwand mit Opazität (Alpha-Transparenz) Fähigkeiten wie so:

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; 

Die DrawOpacityBrush() Verfahren zeichnen ein Update von Remy Lebeau auf eine frühere Anfrage wurde ich vor kurzem gefragt: How to paint on a Canvas with Transparency and Opacity?

Während dies funktioniert, sind die Ergebnisse nicht zufrieden stellend mit dem, was ich jetzt brauche.

Derzeit jedes Mal, wenn die DrawOpacityBrush()-Prozedur in MouseMove aufgerufen wird, wird die Pinselellipsenform gezeichnet. Das ist schlecht, denn je nachdem, wie schnell Sie die Maus über die Zeichenfläche bewegen, ist die Ausgabe nicht wie erhofft.

Diese Beispielbilder sollte dies besser hoffentlich verdeutlichen:

- Die erste rote Bürste ich die Maus bewegt ziemlich schnell aus dem Boden der Leinwand nach oben.
- Der zweite rote Pinsel bewegte ich viel langsamer.

Wie Sie sehen können, wird die Deckkraft korrekt gezeichnet, außer dass der Kreis auch weiterhin gezeichnet wird.

Was Ich mag wäre es stattdessen zu tun ist:

(1) Farbe mit einer Opazität Linie um die Ellipse.

(2) Haben Sie eine Option, um zu verhindern, dass Ellipsen überhaupt gezeichnet werden.

Diese Mock-Probe Bild soll eine Vorstellung davon, wie ich es gezeichnet werden möchte:

Die 3 lila Pinsel Linien zeigen Option (1).

Um Option (2) zu erreichen, sollten die Kreise in den Pinsellinien nicht da sein.

Dies sollte dann erlauben Sie Zeit beim Zeichnen zu nehmen, nicht verzweifelt bewegen Sie die Maus um die Leinwand in der Hoffnung, das gewünschte Ergebnis zu erhalten. Nur wenn Sie sich entscheiden, über den Pinselstrich, den Sie gerade gemacht haben, zurückzukehren, wird die Deckkraft für diesen Bereich dunkler usw.

Wie kann ich diese Art von Zeicheneffekten erzielen?

Ich möchte in der Lage sein, auf eine TImage als das, was ich gerade mache, zu zeichnen, so TCanvas als Parameter in einer Funktion oder Prozedur übergeben wäre ideal. Ich werde auch die MouseDown, MouseMove und MouseUp Ereignisse für meine Zeichnung verwenden.

Dies ist die Ausgabe ich die Methode von NGLN zur Verfügung gestellt bekommen mit:

Opazität scheint auch auf das Bild angewendet werden, es sollte nur die Poly Linien sein.

Answer 1

Warum nicht einfach eine Polylinie zeichnen?

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. 

Das zweite Bild zeigt, wie dies mit einem Hintergrund verbinden und mit der folgenden geringfügigen zusätzlich zu dem Code, während FGraphic ist eine Laufzeit geladen Bild erhalten:

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; 

Oder, um bereits gezeichnete Arbeit zu kombinieren (wie Ihre Image), kopieren Sie ihre Leinwand auf die 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; 

Aber gleichermaßen David in den Kommentaren zu erwähnen, rate ich auch stark alles auf den PaintBox zu ziehen: das ist, was es für ist.