How to add ALPHA to delphi TEXTOUT Tcanvas ?

You need to calculate font color before painting on canvas.

  Canvas.Font.Color := BlendColors(clBtnFace, clWindowText, 50);

function BlendColors(Color1, Color2: TColor; Opacity: Byte): TColor;
var
  r, g, b: Byte;
  c1, c2: PByteArray;
begin
  Color1 := ColorToRGB(Color1);
  Color2 := ColorToRGB(Color2);
  c1 := @Color1;
  c2 := @Color2;

  r := Trunc(c1[0] + (c2[0] - c1[0]) * Opacity / 256);
  g := Trunc(c1[1] + (c2[1] - c1[1]) * Opacity / 256);
  b := Trunc(c1[2] + (c2[2] - c1[2]) * Opacity / 256);

  Result := RGB(r, g, b);
end;

There are several ways how to do this.. Here's one of them:

------------------------------------------------------------

object Image1: TImage
  Left = 2
  Top = 34
  Width = 317
  Height = 269
  OnMouseDown = Image1MouseDown
  OnMouseMove = Image1MouseMove
end
object Edit1: TEdit
  Left = 32
  Top = 0
  Width = 185
  Height = 21
  TabOrder = 0
  Text = 'Some different text'
end
object Label1: TLabel
  Left = 0
  Top = 4
  Width = 21
  Height = 13
  Caption = 'Text'
end
object Edit2: TEdit
  Left = 264
  Top = 0
  Width = 57
  Height = 21
  TabOrder = 1
  Text = '127'
end
object Label2: TLabel
  Left = 232
  Top = 4
  Width = 27
  Height = 13
  Caption = 'Blend'
end
object Bevel1: TBevel
  Left = 0
  Top = 32
  Width = 321
  Height = 273
end

------------------------------------------------------------

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Edit1: TEdit;
    Label1: TLabel;
    Edit2: TEdit;
    Label2: TLabel;
    Bevel1: TBevel;
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure TranspTxt(s : string; x, y : cardinal; BorderX, BorderY : byte; transp : byte);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
with Image1, Picture.Bitmap do begin
  Stretch := true;
  Width := Image1.Width;
  Height := Image1.Height;
  PixelFormat := pf24bit;
end;
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
with Image1.Canvas do
case Button of
  mbLeft  : MoveTo(x, y);
  mbRight : TranspTxt(Edit1.Text, x, y, 4, 0, StrToInt(Edit2.Text));
end;
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if ssLeft in Shift then begin
  Image1.Canvas.LineTo(x, y);
end;
end;

procedure TForm1.TranspTxt(s : string; x, y : cardinal; BorderX, BorderY : byte; transp : byte);
// transp :
//      0 - no   transparency
//    255 - full transparency (invisible)
type
  TLine = array [0..32767] of TRGBTriple;
  PLine = ^TLine;
var
  bmp : TBitmap;
  l1, l2 : PLine;
  w, h : word;
  n1, n2 : single;
begin
bmp := TBitmap.Create;
with bmp do begin
  PixelFormat := Image1.Picture.Bitmap.PixelFormat;
  with Canvas do begin
    with Font do begin      // font params - name, size, style, color, charset etc
      Name := 'Courier New';
      Size := 14;
      Style := [];
      Color := $0000ff; // red
    end;
    Width  := TextWidth (s) + BorderX * 2; // calculate width of text frame
    Height := TextHeight(s) + BorderY * 2; // calculate height of text frame
    Pen  .Width := 3;                      // set border width
    Pen  .Color := $000000;                // color
    Brush.Color := $ffffff;                // background color
    Rectangle(ClipRect);                   // draw frame (background & border)
    Brush.Style := bsClear;
    TextOut(BorderX, BorderY, s);          // draw text
  end;
  n1 := 1 / 255 * transp;
  n2 := 1 - n1;
  for h := 0 to Height - 1 do begin        // put it on Image1.Picture.Bitmap
    if y + h >= Image1.Picture.Bitmap.Height then break; // bottom of the image
    l1 := Image1.Picture.Bitmap.ScanLine[y + h];
    l2 := ScanLine[h];
    for w := 0 to Width - 1 do begin
      if x + w > Image1.Picture.Bitmap.Width then break; // right margin of the image
      l1[x + w].rgbtRed   := Trunc(l1[x + w].rgbtRed   * n1 + l2[w].rgbtRed   * n2);
      l1[x + w].rgbtGreen := Trunc(l1[x + w].rgbtGreen * n1 + l2[w].rgbtGreen * n2);
      l1[x + w].rgbtBlue  := Trunc(l1[x + w].rgbtBlue  * n1 + l2[w].rgbtBlue  * n2);
    end;
  end;
end;
bmp.Free;
Image1.Refresh;
end;

end.

Create an in-memory bitmap.
Use TextOut to write your to the bitmap
Use AlphaBlend to merge the new bitmap and your destination with your required transparency (trans, 0 to 255)

***Note:      AlphaBlend does not work on all systems. The application must be running under Windows 2000 or better***

eg ...
--------------------------------------------------------------------
rocedure TForm1.AlphaTextOut(dest : TCanvas ; x, y: integer; s: string; trans: byte);
var
  MyBMP : TBitmap;
  BlendFunction : TBlendFunction;
  ASize : TSize;
begin
  try
    MyBMP := TBitmap.create;
    GetTextExtentPoint32(MyBMP.Canvas.Handle,PCHAR(s),length(s),ASize);
    MyBMP.Width := MyBMP.Canvas.TextWidth(s);
    MyBMP.Height := MyBMP.Canvas.TextHeight(s);
    MyBMP.Canvas.TextOut(0,0,s);

  with BlendFunction do
    begin
    BlendOp := AC_SRC_OVER;
    BlendFlags := 0;
    SourceConstantAlpha := trans;
    AlphaFormat := 0;
  end;


  windows.AlphaBlend(
    Dest.Handle,                 // handle to destination DC
    x,            // x-coord of upper-left corner
    y,            // y-coord of upper-left corner
    MyBMP.Width,     // width of destination rectangle
    MyBMP.Height,    // height of destination rectangle
    MyBMP.Canvas.Handle,         // handle to source DC
    0,    // x-coord of source upper-left corner
    0,    // y-coord of source upper-left corner
    MyBMP.Width,      // width of source rectangle
    MyBMP.Height,     // height of source rectangle
    blendFunction  // alpha-blending function
    );
  finally
    MyBMP.free;
  end;

end;


procedure TForm1.Button1Click(Sender: TObject);
begin
  AlphaTextOut(image1.picture.bitmap.canvas ,0 ,0, 'A test string' ,200)
end;

Footnote - I would put this "alphaTextOut" in its own class, then have properties like font, color etc
or alternatiively you could pass font & color as paramters, but it gets a bit messy :-)

oops, delete the " GetTextExtentPoint32(MyBMP.Canvas.Handle,PCHAR(s),length(s),ASize);
" line, not needed....

trevsoft, MSDN says that AlphaBlend() is included in Windows 98 and later.


Requirements
  Windows NT/2000/XP: Included in Windows 2000 and later.
  Windows 95/98/Me: Included in Windows 98 and later.
  Header: Declared in Wingdi.h; include Windows.h.
  Library: Included as a resource in Msimg32.dll.

fair 'nuff.

I was reading the WIN32API help that came with Delphi, and that warning was there, so I thought I'd include it.

I had to add 'image1.refresh' after using your AlphaTextOut() function to see results.

Tested your code on Win98SE - it doesn't work :( It says "Access violation at address 00472cee in module 'msimg32.dll'. Read of address 81badfd4."


I tried also my code on that Win98SE - it works without problems.

Why it doesn't work on your win98se is the topic for a whole new question.

In the absence of the OS being specified, i tested the code with D7 under win2k sp4.

I think it's not a topic for new question :) it only shows that if yarek needs it only on w2k and newer, he can use your code. If he needs it also on older systems, he should use some other way.

Only Need the WIN XP or 2000 version.
Can someone set it up together and deliver a corrcted source code ?
Thanks a lot

and I should add that this will use the Curent Font that is set for the TPanel, NOT it's canvas font

to use this -

BlendTextOut(Panel1, 10,10, 'test', 50);