delphi - Canvas Drawing - どうすればこの Alpha Drawing ルーチンを改善できますか?

Question

次のような不透明度（アルファ透明度）機能を備えたキャンバスに描画しています。

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;

描画DrawOpacityBrush()手順は、私が最近尋ねた以前の質問に対する Remy Lebeau による更新でした: How to paint on a Canvas with Transparency and Opacity?

これは機能しますが、結果は私が現在必要としているものには満足できません。

現在、MouseMove でプロシージャが呼び出されるたびにDrawOpacityBrush()、ブラシの楕円形が描画され続けます。キャンバス上でマウスを動かす速さによっては、出力が期待どおりにならないため、これは悪いことです。

これらのサンプル画像は、うまくいけばこれをよりよく説明するはずです:

ここに画像の説明を入力

-最初の赤いブラシマウスをキャンバスの下から上にかなり速く動かしました。
- 2 番目の赤いブラシは、かなりゆっくり動かしました。

ご覧のとおり、不透明度は正しく描画されていますが、円も繰り返し描画され続けています。

代わりにやりたいことは次のとおりです。

(1)楕円の周りに不透明線を塗ります。

(2)楕円がまったく描画されないようにするオプションがあります。

この模擬サンプル画像は、どのように描画したいかのアイデアを与えるはずです:

ここに画像の説明を入力

3 つの紫色のブラシラインは、オプション (1)を示しています。

オプション (2)を実現するには、ブラシライン内の円が存在しないようにする必要があります。

これにより、必要な結果が得られることを期待してマウスをキャンバス上で必死に動かさずに、時間をかけて描画することができます。作成したばかりのブラシストロークに戻ることにした場合にのみ、その領域の不透明度が暗くなります。

このような描画効果を実現するにはどうすればよいですか?

TImage に描画できるようにしたいのですが、それは私が現在行っていることなので、TCanvas を関数またはプロシージャのパラメーターとして渡すのが理想的です。描画には、MouseDown、MouseMove、および MouseUp イベントも使用します。

これは、NGLN が提供するメソッドを使用して取得した出力です。

ここに画像の説明を入力

画像にも不透明度が適用されているようですが、ポリラインのみである必要があります。

score 9 · Accepted Answer

それでは、ポリラインを描画してみませんか?

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.

ブレンドされたポリライン

2 番目の図は、これを背景と組み合わせる方法を示しており、コードに次のマイナーな追加を加えたものですFGraphic。

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;

または、既に描画された作品 ( などImage) を結合するには、そのキャンバスをにコピーします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;

しかし、David がコメントで言及しているように、私もすべてをに描画することを強くお勧めしPaintBoxます。それが目的です。

delphi - Canvas Drawing - どうすればこの Alpha Drawing ルーチンを改善できますか?

1 に答える 1

Related

Reference