Combination of 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 transparent color and draw it to a
• canvas i could create a bitmap and draw it to a canvas with opacity

but i couldn't combine it. if i combine it the 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 (f.e. a blue circle) with transparent background and just 40% opacity?

i would prefere a solution without direct winapi (like bitblt, ...) if possible.

i tried a few hacks like bitshifting a alpha channel to a TColor value but it didn't work.

here i 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:

thanks in advance!

EDIT: my system: delphi xe 5 on windows 7 64bit (but using the 32bit compiler)

Answer 1

What happens can be seen in procedure TBitmap.DrawTransparent in the unit Graphics.
If the property of the image is set to transparent as show for b2 in your example the Bitmap will be drawn with Graphics.TransparentStretchBlt which is using StretchBlt with differnt masks to draw the image and is not able to use the alpha channel. A not tranparent Bitmap , your b1, will be draw with AlphaBlend.

To reach your goal you might use another bitmap b2, set the Alphachannel to 0, paint b2 with opacity $66 on b3, set set the Alphachannel to 255 for every pixel which is clFuchsia in b2 and then paint this bitmap with the desired opacity

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

thanks to bummi (accepted answer)!
i put his solution in a class helper. here is the code if anybody need it:

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.

Answer 3

The oldest answer is fine, please find some easy reshuffle. This example also shows how to put one png-image with opacity on another by respecting the transparency.

procedure TForm2.FormCreate(Sender: TObject);
//define your own transparent color by setting RGB-values
const cTransR=255; cTransG=255; cTransB=255;
      clTrans= $10000*cTransB + $100*cTransG + cTransR;

var bmp1,bmp2:TBitmap;
    pngTemp: TPngImage;
    I:integer;

    procedure SetAlphaTransparent(VAR LBitmap:TBitmap);
    type   TRGBQuadArray = ARRAY [0..0] OF TRGBQuad;
    var    I, J: integer;
           LscanLine32:^TRGBQuadArray;
    begin
        // I found no other way than scanning pixel by pixel to recover default opacity
        for I := 0 to LBitmap.Height - 1 do begin
          LscanLine32:=LBitmap.ScanLine[I];
          for J := 0 to LBitmap.Width - 1 do
            with LscanLine32[J] do
              if NOT((rgbRed=cTransR)AND(rgbGreen=cTransG)AND(rgbBlue=cTransB)) then
                rgbReserved := 255; // make pixel visible, since transparent is default
        end;
    end;

    Procedure SetAlphaProperty(Var LBitmap:TBitmap; LWidth, LHeight:integer);
    begin
        // You will need a different format Bitmap to allow alpha values
        LBitmap.PixelFormat := pf32Bit;
        LBitmap.HandleType  := bmDIB;
        LBitmap.alphaformat := afDefined;
        LBitmap.Canvas.Brush.Color := clTrans;
        LBitmap.SetSize(LWidth,LHeight);
    end;

begin
  // create any background on your Form, by placing IMG:Timage on the From
  pngTemp := TPngImage.Create;
  pngTemp.LoadFromFile( GetCurrentDir()+'\figure1.png' );
  IMG.Canvas.Draw((IMG.Width-pngTemp.Width) div 2,  // fit png into the center
                  (IMG.Height-pngTemp.Height) div 2,pngTemp);
  pngTemp.Free;

  // First example how it opacity works with transparency
  bmp1 := TBitmap.Create;
  SetAlphaProperty(bmp1,35,35);
  // a circle has a surrouding area, to make transparent
  bmp1.Canvas.Brush.Color := clBlue;
  bmp1.Canvas.Ellipse(5,5,30,30);
  SetAlphaTransparent(bmp1);
  // show some circles with different opacity
  for I := 0 to 7 do
      IMG.Canvas.Draw(I*40-30,10,bmp1,(8-I)*32);
  bmp1.Free;

  // Another example using a different png-file
  bmp2 := TBitmap.Create;
  SetAlphaProperty(bmp2,Img.Width,Img.Height);
  // load a transparent png-file and put it into the alpha bitmap:
  pngTemp := TPngImage.Create;
  pngTemp.LoadFromFile( GetCurrentDir()+'\figure2.png' );
  pngTemp.Transparent := true;
  bmp2.Canvas.Draw((bmp2.Width-pngTemp.Width) div 2,// fit png into the center
                   (bmp2.Height-pngTemp.Height) div 2,pngTemp);
  pngTemp.Free;
  // draw the second image with transparancy and opacity onto the first one
  SetAlphaTransparent(bmp2);
  IMG.Canvas.Draw(0,0,bmp2,$66);
  bmp2.Free;
end;