Question

I am drawing onto a canvas with Opacity (Alpha Transparency) abilities like 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;

The draw DrawOpacityBrush() procedure was an update by Remy Lebeau on a previous question I recently asked: How to paint on a Canvas with Transparency and Opacity?

While this works, the results are not satisfactory to what I now need.

Currently, every time the DrawOpacityBrush() procedure is called in MouseMove it keeps on drawing the brush ellipse shape. This is bad because depending on how quick you move the mouse around the canvas, the output is not as hoped.

These sample images should illustrate this better hopefully:

– The first red brush I moved the mouse pretty rapidly from the bottom of the canvas to the top.
– The second red brush I moved a lot slower.

As you can see the opacity is drawn correctly, except that the circle keeps on drawing repeatedly as well.

What I would like it to do instead is:

(1) Paint with a opacity line around the ellipse.

(2) Have an option to prevent any ellipses been drawn at all.

This mock sample image should give an idea of how I would like it to be drawn:

The 3 purple brush lines demonstrate option (1).

To achieve option (2) the circles inside the brush lines should not be there.

This should then allow you to take time when drawing, not frantically moving the mouse around the canvas in hope of getting the result you need. Only when you decide to go back over the brush stroke you just made will the opacity for that area become darker etc.

How can I achieve these type of drawing effects?

I would like to be able to draw onto a TImage as that is what I am currently doing, so passing TCanvas as a parameter in a function or procedure would be ideal. I will also be using the MouseDown, MouseMove and and MouseUp events for my drawing.

This is the output I get using the method provided by NGLN:

Opacity seems to be applied to the image too, it should only be the poly lines.

Answer 1

Why not just draw a polyline then?

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.

The second picture shows how to combine this with a background and is gotten with the following minor addition to the code, whereas FGraphic is a runtime loaded picture:

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;

Or, to combine already drawn work (like your Image), copy its canvas to the 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;

But alike David mentioning in the comments, I also strongly advise to draw everything on the PaintBox: that is what it is for.