How to draw fade out text on a custom TGraphicControl?
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
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.