How to draw fade out text on a custom TGraphicControl?

Question

I would like to draw fade-out text on a TGraphicControl, something like the tabs on Google Chrome, when there isn't enough space to display the whole text on the Canvas.

So instead of displaying elipsis text (which I know how to do), I want it to fade out like this:

The TGraphicControl needs to have transparent option like TCustomLabel (ControlStyle - [csOpaque]).

---

This is probably an easy task with GDIPlus but I need to use pure GDI.

---

I also try to study the code of TGradText v.1.0 (Direct download) which does (almost) exactly what I need - it can draw transparent text but the result looks very bad and not smooth. I guess it's because it makes a pmCopy mask for this task.

---

Here is the code I wrote based on Andreas Rejbrand answer. I used a PaintBox over a TImage and prerendered the backgound:

type
  TParentControl = class(TWinControl);

{ This procedure is copied from RxLibrary VCLUtils }  
procedure CopyParentImage(Control: TControl; Dest: TCanvas);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
begin
  if (Control = nil) or (Control.Parent = nil) then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
  with Control.Parent do ControlState := ControlState + [csPaintCopy];
  try
    with Control do
    begin
      SelfR := Bounds(Left, Top, Width, Height);
      X := -Left; Y := -Top;
    end;
    { Copy parent control image }
    SaveIndex := SaveDC(DC);
    try
      SetViewportOrgEx(DC, X, Y, nil);
      IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
        Control.Parent.ClientHeight);
      with TParentControl(Control.Parent) do
      begin
        Perform(WM_ERASEBKGND, DC, 0);
        PaintWindow(DC);
      end;
    finally
      RestoreDC(DC, SaveIndex);
    end;
    { Copy images of graphic controls }
    for I := 0 to Count - 1 do begin
      if Control.Parent.Controls[I] = Control then Break
      else if (Control.Parent.Controls[I] <> nil) and
        (Control.Parent.Controls[I] is TGraphicControl) then
      begin
        with TGraphicControl(Control.Parent.Controls[I]) do begin
          CtlR := Bounds(Left, Top, Width, Height);
          if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
            ControlState := ControlState + [csPaintCopy];
            SaveIndex := SaveDC(DC);
            try
              SetViewportOrgEx(DC, Left + X, Top + Y, nil);
              IntersectClipRect(DC, 0, 0, Width, Height);
              Perform(WM_PAINT, DC, 0);
            finally
              RestoreDC(DC, SaveIndex);
              ControlState := ControlState - [csPaintCopy];
            end;
          end;
        end;
      end;
    end;
  finally
    with Control.Parent do ControlState := ControlState - [csPaintCopy];
  end;
end;

type
  PRGB32Array = ^TRGB32Array;
  TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad)-1] of TRGBQuad;

procedure FadeBMToWhite(Bitmap: TBitmap);
var
  w, h: integer;
  y: Integer;
  sl: PRGB32Array;
  x: Integer;
begin
  Bitmap.PixelFormat := pf32bit;
  w := Bitmap.Width;
  h := Bitmap.Height;
  for y := 0 to h - 1  do
  begin
    sl := Bitmap.ScanLine[y];
    for x := 0 to w - 1 do
      with sl[x] do
      begin
        rgbBlue := rgbBlue + x * ($FF - rgbBlue) div w;
        rgbGreen := rgbGreen + x * ($FF - rgbGreen) div w;
        rgbRed := rgbRed + x * ($FF - rgbRed) div w;
      end;
  end;
end;

procedure FadeLastNpx(Canvas: TCanvas; N: Integer; ClientWidth, ClientHeight: Integer);
var
  bm: TBitmap;
begin
  bm := TBitmap.Create;
  try
    bm.Width := N;
    bm.Height := ClientHeight;
    BitBlt(bm.Canvas.Handle, 0, 0, N, ClientHeight,
      Canvas.Handle, ClientWidth - N, 0, SRCCOPY);
    FadeBMToWhite(bm);
    BitBlt(Canvas.Handle, ClientWidth - N, 0, N, ClientHeight,
      bm.Canvas.Handle, 0, 0, SRCCOPY);
  finally
    bm.Free;
  end;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
var
  w: integer;
  r: TRect;
  S: string;
  CurScreen: TBitmap; // offscreen bitmap to speed things up
begin
  with PaintBox1 do
  begin
    CurScreen := TBitmap.Create;
    CurScreen.Width := Width;
    CurScreen.Height := Height;
    CopyParentImage(PaintBox1, CurScreen.Canvas);

    with CurScreen do
    begin
      Canvas.Font.Assign(PaintBox1.Font);

      S := 'This is a string.';
      Canvas.Font.Size := 20;
      w := Canvas.TextWidth(S);
      r := ClientRect;

      Canvas.FrameRect(r); // for testing
      Canvas.Brush.Style := bsClear; 
      DrawText(Canvas.Handle, PChar(S), Length(S), r, DT_SINGLELINE or DT_VCENTER);
      if w > ClientWidth then
        FadeLastNpx(Canvas, 50, ClientWidth, ClientHeight);
    end; // with CurScreen

    Canvas.Draw(0, 0, CurScreen);
  end; // with PaintBox1

  CurScreen.Free;
end;

The result looks like this:

As you can see the right egde of the background is also faded. it looks nice. but I wonder if only the text could be faded with TLama sugeestion?

Answer 1

This should get you started:

unit Unit5;

interface

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

type
  TForm5 = class(TForm)
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
  private
    procedure FadeLast50px;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form5: TForm5;

implementation

{$R *.dfm}

type
  PRGB32Array = ^TRGB32Array;
  TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad)-1] of TRGBQuad;

procedure FadeBMToWhite(Bitmap: TBitmap);
var
  w, h: integer;
  y: Integer;
  sl: PRGB32Array;
  x: Integer;
begin
  Bitmap.PixelFormat := pf32bit;
  w := Bitmap.Width;
  h := Bitmap.Height;
  for y := 0 to h - 1 do
  begin
    sl := Bitmap.ScanLine[y];
    for x := 0 to w - 1 do
      with sl[x] do
      begin
        rgbBlue := rgbBlue + x * ($FF - rgbBlue) div w;
        rgbGreen := rgbGreen + x * ($FF - rgbGreen) div w;
        rgbRed := rgbRed + x * ($FF - rgbRed) div w;
      end;
  end;
end;

procedure TForm5.FadeLast50px;
var
  bm: TBitmap;
begin
  bm := TBitmap.Create;
  try
    bm.SetSize(50, ClientHeight);
    BitBlt(bm.Canvas.Handle, 0, 0, 50, ClientHeight,
      Canvas.Handle, ClientWidth - 50, 0, SRCCOPY);
    FadeBMToWhite(bm);
    BitBlt(Canvas.Handle, ClientWidth - 50, 0, 50, ClientHeight,
      bm.Canvas.Handle, 0, 0, SRCCOPY);
  finally
    bm.Free;
  end;
end;

procedure TForm5.FormPaint(Sender: TObject);
const
  S = 'This is a string.';
var
  w: integer;
  r: TRect;
begin
  Canvas.Font.Size := 20;
  w := Canvas.TextWidth(S);
  r := ClientRect;
  DrawText(Canvas.Handle, S, Length(S), r, DT_SINGLELINE or DT_VCENTER);
  if w > ClientWidth then
    FadeLast50px;
end;

procedure TForm5.FormResize(Sender: TObject);
begin
  Invalidate;
end;

end.

Compiled demo EXE

---

Update

Here's a simple experiment with a background:

unit Unit5;

interface

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

type
  TForm5 = class(TForm)
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form5: TForm5;
  bk: TBitmap;

implementation

{$R *.dfm}

const
  BLENDWIDTH = 100;

type
  PRGB32Array = ^TRGB32Array;
  TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad)-1] of TRGBQuad;

procedure FadeBM(Bitmap: TBitmap);
var
  w, h: integer;
  y: Integer;
  sl: PRGB32Array;
  x: Integer;
begin
  Bitmap.PixelFormat := pf32bit;
  w := Bitmap.Width;
  h := Bitmap.Height;
  for y := 0 to h - 1 do
  begin
    sl := Bitmap.ScanLine[y];
    for x := 0 to w - 1 do
      with sl[x] do
      begin
        rgbReserved := Round(255*x/w);
        rgbRed := rgbRed * rgbReserved div 255;
        rgbGreen := rgbGreen * rgbReserved div 255;
        rgbBlue := rgbBlue * rgbReserved div 255;
      end;
  end;
end;

procedure TForm5.FormCreate(Sender: TObject);
begin
  bk := TBitmap.Create;
  with TOpenDialog.Create(nil) do
    try
      Filter := 'Windows Bitmap|*.bmp';
      if Execute then
        bk.LoadFromFile(FileName)
    finally
      Free;
    end;
end;

procedure TForm5.FormPaint(Sender: TObject);
const
  S = 'This is a string.';
var
  w: integer;
  r: TRect;
  bf: TBlendFunction;
  bk2: TBitmap;
begin
  // Draw backgrond
  BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight, Bk.Canvas.Handle, 0, 0, SRCCOPY);
  // Draw text
  Canvas.Font.Size := 20;
  Canvas.Brush.Style := bsClear;
  w := Canvas.TextWidth(S);
  r := ClientRect;
  DrawText(Canvas.Handle, S, Length(S), r, DT_SINGLELINE or DT_VCENTER);
  if w > ClientWidth then
  begin
    bk2 := TBitmap.Create;
    try
      bk2.SetSize(BLENDWIDTH, ClientHeight);
      BitBlt(bk2.Canvas.Handle, 0, 0, BLENDWIDTH, ClientHeight, Bk.Canvas.Handle, ClientWidth - BLENDWIDTH, 0, SRCCOPY);
      FadeBM(bk2);
      bf.BlendOp := AC_SRC_OVER;
      bf.BlendFlags := 0;
      bf.SourceConstantAlpha := 255;
      bf.AlphaFormat := AC_SRC_ALPHA;
      Windows.AlphaBlend(Canvas.Handle, ClientWidth - BLENDWIDTH, 0, BLENDWIDTH, ClientHeight, bk2.Canvas.Handle, 0, 0, BLENDWIDTH, ClientHeight, bf);
    finally
      bk2.Free;
    end;
  end;
end;

procedure TForm5.FormResize(Sender: TObject);
begin
  Invalidate;
end;

end.

Compiled demo EXE

Sample background bitmap

Answer 2

Hereby Andreas' code (votes should be for him!) incorporated into a stand alone component:

unit FadingTextControl;

interface

uses
  Classes, Controls, Windows, Graphics;

type
  TFadingTextControl = class(TGraphicControl)
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Caption;
    property Font;
  end;

implementation

{ TFadingTextControl }

constructor TFadingTextControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csOpaque];
end;

procedure TFadingTextControl.Paint;
const
  FadeWidth = 100;
var
  R: TRect;
  Overlay: TBitmap;
  BlendFunc: TBlendFunction;

  procedure FadeOverlay;
  type
    PRGB32Array = ^TRGB32Array;
    TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad) - 1] of TRGBQuad;
  var
    W: Integer;
    Y: Integer;
    Line: PRGB32Array;
    X: Integer;
  begin
    Overlay.PixelFormat := pf32bit;
    W := Overlay.Width;
    for Y := 0 to Overlay.Height - 1 do
    begin
      Line := Overlay.ScanLine[Y];
      for X := 0 to W - 1 do
        with Line[X] do
        begin
          rgbReserved := Round(255 * X / W);
          rgbRed := rgbRed * rgbReserved div 255;
          rgbGreen := rgbGreen * rgbReserved div 255;
          rgbBlue := rgbBlue * rgbReserved div 255;
        end;
    end;
  end;

begin
  R := ClientRect;
  Canvas.Font.Assign(Font);
  Canvas.Brush.Style := bsClear;
  if Canvas.TextWidth(Caption) <= Width then
    DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_SINGLELINE or DT_VCENTER)
  else
  begin
    Overlay := TBitmap.Create;
    try
      Overlay.Width := FadeWidth;
      Overlay.Height := Height;
      BitBlt(Overlay.Canvas.Handle, 0, 0, FadeWidth, Height, Canvas.Handle,
        Width - FadeWidth, 0, SRCCOPY);
      DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_SINGLELINE or
        DT_VCENTER);
      FadeOverlay;
      BlendFunc.BlendOp := AC_SRC_OVER;
      BlendFunc.BlendFlags := 0;
      BlendFunc.SourceConstantAlpha := 255;
      BlendFunc.AlphaFormat := AC_SRC_ALPHA;
      AlphaBlend(Canvas.Handle, Width - FadeWidth, 0, FadeWidth, Height,
        Overlay.Canvas.Handle, 0, 0, FadeWidth, Height, BlendFunc);
    finally
      Overlay.Free;
    end;
  end;
end;

end.