Canvas Drawing - How can I Improve this Alpha Drawing routine?

delphi, delphi-xe

Solution

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.

Problem

Original source

Related problems

• How to paint on a Canvas with Transparency and Opacity?