Combining Canvas.TransparentColor and Canvas.Draw with Opacity

Question

I want to draw a bitmap on a canvas with opacity, where the bitmap has a transparent color.

• I could create a bitmap with a transparent color and draw it
• canvas i can create a bitmap and draw it on canvas with opacity

but I could not combine it. if I combine it, opacity is ignored.

here is the code i wrote:

procedure TForm1.FormPaint(Sender: TObject);
var b1,b2:TBitmap;
begin
  // Example how it opacity works:
  b1 := TBitmap.Create;
  b1.SetSize(20,20);
  b1.Canvas.Brush.Color := clBlue;
  b1.Canvas.Rectangle(0,0,20,20);
  Canvas.Draw(10,10,b1,$ff);  // Works
  Canvas.Draw(40,10,b1,$66);  // Works

  // I need it in combination with TransparentColor:
  b2 := TBitmap.Create;
  // next 3 lines are different from above
  b2.Transparent := true;
  b2.TransparentColor := clFuchsia;
  b2.Canvas.Brush.Color := clFuchsia;
  b2.SetSize(20,20);
  b2.Canvas.Brush.Color := clBlue;
  b2.Canvas.Ellipse(0,0,20,20);
  Canvas.Draw(10,40,b2,$ff);  // Works (full opacity)
  Canvas.Draw(40,40,b2,$66);  // Ignores the $66 Opacity

  b1.Free;
  b2.Free;
end;

produces:

How could I draw (for example, a blue circle) with a transparent background and opacity of only 40%?

I would prefer a solution without direct winapi (e.g. bitblt, ...) if possible.

I tried several hacks, such as the alpha channel bitrate, to the TColor value, but it did not work.

here i am what i tried:

procedure TForm1.FormPaint(Sender: TObject);
var b:TBitmap;
begin
  b := TBitmap.Create;
  b.PixelFormat := pf32bit;
  b.AlphaFormat := afDefined;

  b.Canvas.Brush.Color := 0 and ($ff shl 32);  // Background Transperency
  b.SetSize(20,20);
  b.Canvas.Brush.Color := clBlue + (($ff-$66) shl 32);
  b.Canvas.Ellipse(0,0,20,20);
  Canvas.Draw(10,10,b);

  b.Free;
end;

produces:

early!

EDIT: : delphi xe 5 Windows 7 64bit ( 32- )

Answer 1

procedure TBitmap.DrawTransparent Graphics.
, b2 , Graphics.TransparentStretchBlt, StretchBlt -. , b1, AlphaBlend.

, bitmap b2, Alphachannel 0, b2 $66 b3, Alphachannel 255 , clFuchsia b2,

type
  pRGBQuadArray = ^TRGBQuadArray;
  TRGBQuadArray = ARRAY [0 .. 0] OF TRGBQuad;
  TRefChanel=(rcBlue,rcRed,rcGreen);

procedure SetBitmapAlpha(ABitmap: TBitMap; Alpha: Byte);
var
  pscanLine32: pRGBQuadArray;
  nScanLineCount, nPixelCount : Integer;
begin
  with ABitmap do
  begin
    PixelFormat := pf32Bit;
    HandleType := bmDIB;
    ignorepalette := true;
    alphaformat := afDefined;
    for nScanLineCount := 0 to Height - 1 do
    begin
      pscanLine32 := Scanline[nScanLineCount];
      for nPixelCount := 0 to Width - 1 do
        with pscanLine32[nPixelCount] do
         begin
          rgbReserved := Alpha;
        end;
    end;
  end;
end;

procedure AdaptBitmapAlpha(ABitmap,TranspBitmap:TBitmap);
var
  pscanLine32,pscanLine32_2: pRGBQuadArray;
  nScanLineCount, nPixelCount : Integer;
begin
  with ABitmap do
  begin
    PixelFormat := pf32Bit;
    HandleType := bmDIB;
    ignorepalette := true;
    alphaformat := afDefined;
    for nScanLineCount := 0 to Height - 1 do
    begin
      pscanLine32 := Scanline[nScanLineCount];
      pscanLine32_2 := TranspBitmap.Scanline[nScanLineCount];
      for nPixelCount := 0 to Width - 1 do
        with pscanLine32[nPixelCount] do
         begin
          // all picels with are not clFuchsia in the transparent bitmap
          if NOT ((pscanLine32_2[nPixelCount].rgbBlue=255) AND (pscanLine32_2[nPixelCount].rgbRed=255) AND (pscanLine32_2[nPixelCount].rgbGreen=0)  ) then
             begin
             rgbReserved := 255;
             end
          else
             begin
               rgbBlue := 0;
               rgbRed := 0;
               rgbGreen := 0;
             end;
        end;
    end;
  end;
end;



procedure TAForm.FormPaint(Sender: TObject);

var b1,b2,b3:TBitmap;
BF: TBlendFunction;
begin
  // Example how it opacity works:
  b1 := TBitmap.Create;
  b1.SetSize(20,20);
  b1.Canvas.Brush.Color := clBlue;
  b1.Canvas.Rectangle(0,0,20,20);
  Canvas.Draw(10,10,b1,$ff);  // Works
  Canvas.Draw(40,10,b1,$66);  // Works

  // I need it in combination with TransparentColor:
  b3 := TBitmap.Create;
  b3.PixelFormat := pf32Bit;

  b2 := TBitmap.Create;
  b2.PixelFormat := pf32Bit;
  // next 3 lines are different from above
  b2.Transparent := true;
  b2.TransparentColor := clFuchsia;
  b2.Canvas.Brush.Color := clFuchsia;
  b2.SetSize(20,20);
  b2.Canvas.Brush.Color := clBlue;
  b2.Canvas.Ellipse(0,0,20,20);

  Canvas.Draw(10,40,b2,$ff);  // Works (full opacity)

  b3.SetSize(20,20);
  SetBitmapAlpha(b3,0);
  b3.Canvas.Draw(0,0,b2,$66);
  AdaptBitmapAlpha(b3,b2);
  Canvas.Draw(40,40,b3,$66);

  b1.Free;
  b2.Free;
  b3.Free;
end;

Answer 2

bummi ( )!
. , - :

unit uBitmapHelper;

interface

uses
  Vcl.Graphics;

type
  TBitmapHelper = class Helper for TBitmap
  private
  type
    TRgbaRec = packed record
      r,g,b,a:Byte;
    end;
    PRgbaRec = ^TRgbaRec;
    PRgbaRecArray = ^TRgbaRecArray;
    TRgbaRecArray = array [0 .. 0] of TRgbaRec;
  public
    procedure TransparentMaskedDraw(ACanvas:TCanvas;AX:Integer;AY:Integer;AMask:TColor;AOpacity:Byte);
  end;

implementation

{ TBitmapHelper }

procedure TBitmapHelper.TransparentMaskedDraw(ACanvas:TCanvas;AX,AY:Integer;AMask:TColor;AOpacity:Byte);
var i,j:Integer;
    line1,line2:PRgbaRecArray;
    mask:PRgbaRec;
    tmp:TBitmap;
begin
  mask := @AMask;
  tmp := TBitmap.Create;
  tmp.SetSize(self.Width,self.Height);
  tmp.PixelFormat := pf32Bit;
  tmp.HandleType := bmDIB;
  tmp.IgnorePalette := true;
  tmp.AlphaFormat := afDefined;
  for i := 0 to tmp.Height - 1 do begin
    line1 := tmp.Scanline[i];
    for j := 0 to tmp.Width - 1 do begin
      line1[j].a := 0;
    end;
  end;
  tmp.Canvas.Draw(0,0,self,AOpacity);
  for i := 0 to tmp.Height - 1 do begin
    line1 := tmp.ScanLine[i];
    line2 := self.ScanLine[i];
    for j := 0 to tmp.Width - 1 do begin
      if not((line2[j].r = mask.r) and (line2[j].g = mask.g) and (line2[j].b = mask.b)) then begin
        line1[j].a := $ff;
      end else begin
        line1[j].r := 0;
        line1[j].g := 0;
        line1[j].b := 0;
      end;
    end;
  end;
  ACanvas.Draw(AX,AY,tmp,AOpacity);
  tmp.Free;
end;

end.