How to draw fade out text on a custom TGraphicControl?

Viewed 1596

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: delphi

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:

enter image description here

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?

2 Answers
Related