Given a Delphi TPicture containing some TGraphic descendant, I need to figure pixel color and opacity.
I think I have to have different implementations for each class, and I think I've got TPngImage covered. Is there any support for transparency in 32bit Bitmaps?
Can I address the problem in a more general way than the following?:
procedure GetPixelColorAndTransparency(const Picture: TPicture; X, Y:
Integer; out Color: TColor; out Opacity: Byte);
var
Bmp: TBitmap;
begin
if Picture.Graphic is TPngImage then
begin
Opacity := (TPngImage(Picture.Graphic).AlphaScanline[Y]^)[X];
Color := TPngImage(Picture.Graphic).Pixels[ X, Y ];
end
else
if Picture.Graphic is TBitmap then
begin
Color := Picture.Bitmap.Canvas.Pixels[ X, Y ];
Opacity := 255;
end
else
begin
Bmp := TBitmap.Create;
try
Bmp.Assign(Picture.Graphic);
Color := Bmp.Canvas.Pixels[ X, Y ];
Opacity := 255;
finally
Bmp.Free;
end;
end;
end;
How about something like this:
procedure GetPixelColorAndTransparency(const Picture: TPicture; X, Y: Integer; out Color: TColor; out Opacity: Byte);
type
PRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray = array [Integer] of TRGBQuad;
var
Bmp: TBitmap;
begin
if Picture.Graphic is TPngImage then
begin
with TPngImage(Picture.Graphic) do begin
Opacity := AlphaScanline[Y]^[X];
Color := Pixels[X, Y];
end;
end
else if Picture.Graphic is TBitmap then
begin
with Picture.Bitmap do begin
Color := Canvas.Pixels[X, Y];
if PixelFormat = pf32Bit then begin
Opacity := PRGBQuadArray(Scanline[Y])^[X].rgbReserved;
end
else if Color = TranparentColor then begin
Opacity := 0;
end
else begin
Opacity := 255;
end;
end;
end else
begin
Bmp := TBitmap.Create;
try
Bmp.Assign(Picture.Graphic);
Color := Bmp.Canvas.Pixels[X, Y];
if Color = Bmp.TranparentColor then begin
Opacity := 0;
end else begin
Opacity := 255;
end;
finally
Bmp.Free;
end;
end;
end;
It is not optimized but simple to understand:
procedure GetPixelColorAndTransparency(const Picture: TPicture; X, Y:
Integer; out Color: TColor; out Opacity: Byte);
var
Bmp: TBitmap;
Color32: Cardinal;
begin
Bmp := TBitmap.Create;
try
Bmp.Assign(Picture.Graphic);
Color32 := Bmp.Canvas.Pixels[ X, Y ];
Color := Color32 and $00FFFFFF;
Opacity := Color32 shr 24;
finally
Bmp.Free;
end;
end;
Related
Problem Definition
I am trying to create a custom bitmap brush with transparency but it doesn't seem to be working as expected. If you look at this example. Add the code and hook up the paint, create and destroy events.
type
TForm3 = class(TForm)
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
FBitmap: TBitmap;
end;
// Implementation
function CreateBlockBitmap(const APenColor: TColor): TBitmap;
begin
Result := TBitmap.Create;
Result.Transparent := True;
Result.Canvas.Brush.Color := clWhite;
Result.Canvas.Brush.Style := bsClear;
Result.PixelFormat := pf32bit;
Result.SetSize(20, 20);
Result.Canvas.Brush.Color := APenColor;
Result.Canvas.Brush.Style := bsSolid;
Result.Canvas.FillRect(Rect(0,0,10,10));
end;
procedure TForm3.FormDestroy(Sender: TObject);
begin
FBitmap.Free;
end;
procedure TForm3.FormCreate(Sender: TObject);
begin
FBitmap := CreateBlockBitmap(clRed);
end;
procedure TForm3.FormPaint(Sender: TObject);
var
colNum: Integer;
rowNum: Integer;
begin
// Paint the rectangle using the brush
Canvas.Pen.Color := clGreen;
Canvas.Brush.Bitmap := FBitmap; // This is using bitmap
Canvas.Rectangle(50, 50, 250, 250);
// Draw the block using Canvas.Draw
for rowNum := 0 to 9 do
for colNum := 0 to 9 do
Canvas.Draw(350 + rowNum * 20, 50 + colNum * 20, FBitmap);
end;
This code produces two painted blocks. The left one is painted using a bitmap brush and the right hand side one is painted using a number of Canvas.Draw calls.
I need the brush to be painted with transparency similar to what would happen if you used a hatch brush. This SO answer seems to indicate that it's possible:
How can I draw a patternBrush with transparent backround (GDI)?
What I have tried
1) I tried using a solid background color instead of using bsClear. This just makes the background white.
Result.Canvas.Brush.Color := clWhite;
Result.Canvas.Brush.Style := bsSolid;
If I use clFuchsia then the color is Fuchsia. I also tried painting the background clFuchsia and then setting the TransparentColor to clFuchsia. The Canvas.Draw option paints with transparency and the brush doesn't.
2) I tried setting the alpha channel directly with the following code:
procedure SetAlphaBitmap(const Dest: TBitmap;Color : TColor;Alpha:Byte);
type
TRGB32 = record
B, G, R, A: byte;
end;
PRGBArray32 = ^TRGBArray32;
TRGBArray32 = array[0..0] of TRGB32;
var
x, y: integer;
Line, Delta: integer;
ColorRGB : TColor;
begin
if Dest.PixelFormat<>pf32bit then exit;
ColorRGB := ColorToRGB(Color);
Line := integer(Dest.ScanLine[0]);
Delta := integer(Dest.ScanLine[1]) - Line;
for y := 0 to Dest.Height - 1 do
begin
for x := 0 to Dest.Width - 1 do
if TColor(RGB(PRGBArray32(Line)[x].R, PRGBArray32(Line)[x].G, PRGBArray32(Line)[x].B)) = ColorRGB then
PRGBArray32(Line)[x].A := Alpha;
Inc(Line, Delta);
end;
end;
And then calling this routine immediately after the rectangle has been painted using the background color.
Result.Canvas.Brush.Style := bsSolid;
Result.Canvas.FillRect(Rect(0,0,10,10));
SetAlphaBitmap(Result, clBlack, 0); // Set the alpha channel
end;
I know that the alpha channel is working because if I pass in an alpha value of 255 then it shows up in black in the Canvas.Draw too.
SetAlphaBitmap(Result, clBlack, 255);
3) I tried testing by creating a pattern brush and assigning that instead of the bitmap. That produces exactly the same results. FBrush is an HBRUSH.
FBrush := CreatePatternBrush(FBitmap.Handle);
And the setting the brush like this:
Canvas.Brush.Handle := FBrush;
4) I tried calling SetBkMode as indicated in the SO answer above. That made no difference at all.
Canvas.Pen.Color := clGreen;
Canvas.Brush.Bitmap := FBitmap;
SetBkMode(Canvas.Handle, TRANSPARENT); // This doesn't make a difference
Canvas.Rectangle(50, 50, 250, 250);
Edit
5) I just tested with a Monochrome bitmap and it has the same problem. The image is painted with a white background and black foreground for the brush and transparent for the Canvas.Draw.
function CreateMonochromeBitmap: TBitmap;
begin
Result := TBitmap.Create;
Result.Transparent := True;
Result.Canvas.Brush.Color := clWhite;
Result.Canvas.Brush.Style := bsSolid;
Result.PixelFormat := pf1bit;
Result.SetSize(20, 20);
Result.Canvas.Brush.Color := clBlack;
Result.Canvas.Brush.Style := bsSolid;
Result.Canvas.FillRect(Rect(0,0,10,10));
end;
And in the constructor:
FBitmap := CreateMonochromeBitmap;
FBrush := CreatePatternBrush(FBitmap.Handle);
In the paint we set the handle rather than the bitmap property.
Canvas.Brush.Handle := FBrush;
Try to clear the canvas this null color before your drawing loop.
Canvas.Clear(TAlphaColorRec.Null);
Greetings.
Pau.
You need to use white color for transparent areas and SetROP2 before filling the rectangle, like this:
Canvas.Brush.Bitmap := FBitmap; // This is using bitmap
SetROP2(Canvas.Handle, R2_MASKPEN);
Canvas.Rectangle(50, 50, 250, 250);
And don't forget to restore the previous ROP mode.
Good luck!
Solved! Here is my solution:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
public
FBitmap: TBitmap;
end;
//Implementation
function CreateBlockBitmap: TBitmap;
begin
Result := TBitmap.Create;
Result.PixelFormat := pf1bit; //!! 1-bit
Result.Width := 20;
Result.Height := 20;
Result.Canvas.Brush.Color := clBlack;
Result.Canvas.FillRect(Rect(0, 0, 10, 10));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FBitmap := CreateBlockBitmap;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FBitmap.Free;
end;
procedure TForm1.FormPaint(Sender: TObject);
const
PatternColor = clRed; //brush color to be used
var
R: TRect;
begin
//filling the background with different colors for test
Canvas.Brush.Color := clGreen;
Canvas.FillRect(Rect(0,0,100,600));
Canvas.Brush.Color := clAqua;
Canvas.FillRect(Rect(100,0,200,600));
Canvas.Brush.Color := clYellow;
Canvas.FillRect(Rect(200,0,300,600));
Canvas.Brush.Color := clWhite;
Canvas.FillRect(Rect(300,0,400,600));
//draw the rectangle
R := Rect(50, 50, 500, 500);
Canvas.Brush.Color := PatternColor;
BitBlt(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom, Canvas.Handle, 0, 0, PATINVERT);
Canvas.Brush.Bitmap := FBitmap;
SetROP2(Canvas.Handle, R2_MASKPEN);
Canvas.Rectangle(R); //draw any figure here
Canvas.Brush.Color := PatternColor;
SetROP2(Canvas.Handle, R2_COPYPEN);
BitBlt(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom, Canvas.Handle, 0, 0, PATINVERT);
end;
I am trying to convert a gif to png, that's easy, but the problem is the result image is not transparent, also I would like to have in the png image the alpha channel.
This is my code:
procedure TForm1.Button1Click(Sender: TObject);
var
png: TPngImage;
p : TPicture;
begin
p := TPicture.Create;
p.LoadFromFile('C:\temp\php.gif');
png := TPngImage.CreateBlank(COLOR_RGB , 8, p.Width, p.Height);
png.Canvas.Draw(0,0, p.Graphic);
png.SaveToFile('C:\Windows\Temp\test.png');
end;
The new picture has the background black, should be transparent.
If I try to add the ALPHA in the constructor, is 100% transparent.
png := TPngImage.CreateBlank(COLOR_RGBALPHA , 8, p.Width, p.Height);
Since Delphi XE 2 GDI+ is supported, which offers real easy to use options for conversions.
You just need to create TGPImage providing the image file to load and save this image with the wished encoder, found by the desired mime type.
uses Winapi.GDIPAPI, Winapi.GDIPOBJ, Winapi.GDIPUTIL;
procedure TForm8.Button1Click(Sender: TObject);
var
encoderClsid: TGUID;
stat: TStatus;
IMG: TGPImage;
begin
IMG := TGPImage.Create('C:\temp\transparent.gif');
try
GetEncoderClsid('image/png', encoderClsid);
stat := IMG.Save('C:\temp\transparent.png', encoderClsid, nil);
finally
IMG.Free;
end;
if (stat = Ok) then
Showmessage('Success');
end;
examples for the mime types:
image/bmp
image/jpeg
image/gif
image/tiff
image/png
Just by drawing GIF image on PNG canvas will not move transparency information from GIF image to PNG.
You will have to do it yourself.
ForceAlphaChannel procedure will create alpha channel for any PNG image based on given TransparentColor.
procedure ForceAlphaChannel(Image: TPngImage; BitTransparency: Boolean; TransparentColor: TColor; Amount: Byte);
var
Temp: TPngImage;
x, y: Integer;
Line: VCL.Imaging.PngImage.pByteArray;
PixColor: TColor;
begin
Temp := TPngImage.CreateBlank(COLOR_RGBALPHA, 8, Image.Width, Image.Height);
try
for y := 0 to Image.Height - 1 do
begin
Line := Temp.AlphaScanline[y];
for x := 0 to Image.Width - 1 do
begin
PixColor := Image.Pixels[x, y];
Temp.Pixels[x, y] := PixColor;
if BitTransparency and (PixColor = TransparentColor) then Line^[x] := 0
else Line^[x] := Amount;
end;
end;
Image.Assign(Temp);
finally
Temp.Free;
end;
end;
If you add call to ForceAlphaChannel after you have drawn GIF image you will get transparency based on transparent color you define.
procedure TForm1.Button1Click(Sender: TObject);
var
png: TPngImage;
p : TPicture;
TransparentColor: TColor;
begin
p := TPicture.Create;
p.LoadFromFile('C:\temp\php.gif');
TransparentColor := clFuchsia;
png := TPngImage.CreateBlank(COLOR_RGB , 8, p.Width, p.Height);
// set png background color to same color that will be used for setting transparency
png.Canvas.Brush.Color := TransparentColor;
png.Canvas.FillRect(rect(0, 0 , p.Width, p.Height));
png.Canvas.Draw(0, 0, p.Graphic);
ForceAlphaChannel(png, true, TransparentColor, 255);
png.SaveToFile('C:\Windows\Temp\test.png');
end;
For older/new Delphi versions (in newer version - change TPngObject to TPngImage).
If you need to save every frame of (animated) GIF into PNG (works for non-animated GIFS also):
The first variant code is compatible with the newer pngimage Version 1.56+ (which supports the CreateBlank constructor)
procedure TForm1.Button1Click(Sender: TObject);
var
Gif: TGifImage;
Png: TPngObject; // for new Delphi versions use "TPngImage"
Bmp: TBitmap;
TransparentColor, Pixel: TColor;
I, X, Y: Integer;
AlphaScanline: pByteArray;
IsTransparent: Boolean;
ColorType: Cardinal;
begin
Gif := TGifImage.Create;
try
Gif.LoadFromFile('C:\Downloads\ajax-loader.gif');
for I := 0 to Gif.Images.Count - 1 do
begin
IsTransparent := Gif.Images[I].Transparent;
TransparentColor := Gif.Images[I].GraphicControlExtension.TransparentColor;
Bmp := Gif.Images[I].Bitmap;
if IsTransparent then
ColorType := COLOR_RGBALPHA
else
ColorType := COLOR_RGB;
Png := TPngObject.CreateBlank(ColorType, 8, Bmp.Width, Bmp.Height); // for new Delphi versions use "TPngImage"
try
AlphaScanline := nil;
for Y := 0 to Bmp.Height - 1 do
begin
if IsTransparent then
AlphaScanline := Png.AlphaScanline[Y];
for X := 0 to Bmp.Width - 1 do
begin
Pixel := Bmp.Canvas.Pixels[X, Y];
Png.Pixels[X, Y] := Pixel;
if IsTransparent then
begin
if (Pixel = TransparentColor) then
AlphaScanline^[X] := 0
else
AlphaScanline^[X] := 255;
end;
end;
end;
Png.SaveToFile(Format('%d.png', [I]));
finally
Png.Free;
end;
end;
finally
Gif.Free;
end;
end;
For old pngimage version before 1.56 which do not support TPngObject.CreateBlank:
procedure TForm1.Button2Click(Sender: TObject);
var
Gif: TGifImage;
Png: TPngObject; // for new Delphi versions use "TPngImage"
Bmp: TBitmap;
TransparentColor, Pixel: TColor;
I, X, Y: Integer;
AlphaScanline: pByteArray;
IsTransparent: Boolean;
begin
Gif := TGifImage.Create;
try
Gif.LoadFromFile('C:\Downloads\ajax-loader.gif');
for I := 0 to Gif.Images.Count - 1 do
begin
IsTransparent := Gif.Images[I].Transparent;
Png := TPngObject.Create; // for new Delphi versions use "TPngImage"
try
if IsTransparent then
begin
Bmp := TBitmap.Create;
Bmp.Assign(Gif.Images[I].Bitmap);
Bmp.PixelFormat := pf24bit;
Png.Assign(Bmp);
Png.CreateAlpha;
TransparentColor := Gif.Images[I].GraphicControlExtension.TransparentColor;
for Y := 0 to Bmp.Height - 1 do
begin
AlphaScanline := Png.AlphaScanline[Y];
for X := 0 to Bmp.Width - 1 do
begin
Pixel := Png.Pixels[X, Y];
if (Pixel = TransparentColor) then
AlphaScanline^[X] := 0;
end;
end;
Bmp.Free;
end
else
Png.Assign(Gif.Images[I].Bitmap);
Png.SaveToFile(Format('%d.png', [I]));
finally
Png.Free;
end;
end;
finally
Gif.Free;
end;
end;
i need to convert all pixels of a canvas
found this function after a quick search in google
but dont work correct , but it seems must work good!!
function RGBBitmapTo1Bit(OriginalBitmap : TBitmap) : TBitmap;
var
x, y : integer;
begin
result := TBitmap.Create;
result.width := OriginalBitmap.width;
result.height := OriginalBitmap.height;
for x := 1 to OriginalBitmap.width do
for y := 1 to OriginalBitmap.height do
begin
result.Canvas.Pixels[x, y] := clBlack;
end;
end;
this function dont make any change on the file
for example i used like this
procedure TForm1.Button2Click(Sender: TObject);
var
imgf : TBitmap;
begin
if od1.Execute then
begin
imgf := TBitmap.Create;
imgf.LoadFromFile(od1.FileName);
RGBBitmapTo1Bit(imgf);
imgf.SaveToFile(ExtractFilePath(od1.FileName)+'test.bmp');
end;
but the output and input files are the same!!!
how can i assign a color to a pixel rightly!?
Your code has three problems with it:
Pixels are 0-indexed in both dimensions, so you need to change your loops accordingly.
for x := 0 to OriginalBitmap.width-1 do
for y := 0 to OriginalBitmap.height-1 do
your function DOES NOT modify the original TBitmap, it allocates and modifies a new TBitmap and then returns that to the caller, but the caller is ignoring that new bitmap, expecting the original TBitmap to have been modified instead. You are saving the original TBitmap to file, which is why you don't see any of the pixels changed.
You are leaking memory for both TBitmap objects;
Try this instead:
function RGBBitmapTo1Bit(OriginalBitmap : TBitmap) : TBitmap;
var
x, y : integer;
begin
Result := TBitmap.Create;
Result.Width := OriginalBitmap.Width;
Result.Height := OriginalBitmap.Height;
for x := 0 to OriginalBitmap.Width-1 do
for y := 0 to OriginalBitmap.Height-1 do
begin
Result.Canvas.Pixels[x, y] := clBlack;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
imgf : TBitmap;
imgf2 : TBitmap;
begin
if od1.Execute then
begin
imgf := TBitmap.Create;
try
imgf.LoadFromFile(od1.FileName);
imgf2 := RGBBitmapTo1Bit(imgf);
try
imgf2.SaveToFile(ExtractFilePath(od1.FileName)+'test.bmp');
finally
imgf2.Free;
end;
finally
imgf.Free;
end;
end;
end;
Or this:
procedure RGBBitmapTo1Bit(OriginalBitmap : TBitmap);
var
x, y : integer;
begin
for x := 0 to OriginalBitmap.Width-1 do
for y := 0 to OriginalBitmap.Height-1 do
begin
OriginalBitmap.Canvas.Pixels[x, y] := clBlack;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
imgf : TBitmap;
begin
if od1.Execute then
begin
imgf := TBitmap.Create;
try
imgf.LoadFromFile(od1.FileName);
RGBBitmapTo1Bit(imgf);
imgf.SaveToFile(ExtractFilePath(od1.FileName)+'test.bmp');
finally
imgf.Free;
end;
end;
end;
That being said, RGBBitmapTo1Bit() is slow in both versions. A faster version would be more like this:
function RGBBitmapTo1Bit(OriginalBitmap : TBitmap) : TBitmap;
begin
Result := TBitmap.Create;
Result.Width := OriginalBitmap.Width;
Result.Height := OriginalBitmap.Height;
Result.Canvas.Brush.Color := clBlack;
Result.Canvas.FillRect(Rect(0, 0, Result.Width, Result.Height));
end;
function RGBBitmapTo1Bit(OriginalBitmap : TBitmap) : TBitmap;
begin
Result := TBitmap.Create;
Result.Canvas.Brush.Color := clBlack;
Result.Width := OriginalBitmap.Width;
Result.Height := OriginalBitmap.Height;
end;
Or:
procedure RGBBitmapTo1Bit(OriginalBitmap : TBitmap);
begin
OriginalBitmap.Canvas.Brush.Color := clBlack;
OriginalBitmap.Canvas.FillRect(Rect(0, 0, OriginalBitmap.Width, OriginalBitmap.Height));
end;
It also does not do what its name suggests - convert a bitmap to 1bit. To do that, you have to set the TBitmap.PixelFormat property instead:
function RGBBitmapTo1Bit(OriginalBitmap : TBitmap) : TBitmap;
begin
Result := TBitmap.Create;
Result.PixelFormat := pf1Bit;
Result.Canvas.Brush.Color := clBlack;
Result.Width := OriginalBitmap.Width;
Result.Height := OriginalBitmap.Height;
end;
Or:
procedure RGBBitmapTo1Bit(OriginalBitmap : TBitmap);
begin
OriginalBitmap.PixelFormat := pf1Bit;
OriginalBitmap.Canvas.Brush.Color := clBlack;
OriginalBitmap.Canvas.FillRect(Rect(0, 0, OriginalBitmap.Width, OriginalBitmap.Height));
end;
I have a 2-dimensional array of TColor. And also I have a TCanvas. How can I draw this color map on canvas faster than with a for cycle?
For Example:
type
T2DAr = array of array of TColor;
var
ar: T2DAr;
Form1: TForm; // mainform
function main;
var x, y: integer;
begin
{filling array with colors as a 10x10}
for x := 0 to length(ar)-1 do
for y := 0 to length(ar[x])-1 do
Form1.Canvas.Pixels[x, y] := ar[x, y];
end;
This way works too slowly. I need a faster algorithm.
This has been answered many times. The answer is: use scanlines instead of the terribly slow Pixels property. Example:
function CreateBitmapReallyFast: TBitmap;
const
WHITE: TRGBTriple = (rgbtBlue: 255; rgbtGreen: 255; rgbtRed: 255);
BLACK: TRGBTriple = (rgbtBlue: 0; rgbtGreen: 0; rgbtRed: 0);
var
y: Integer;
scanline: PRGBTriple;
x: Integer;
begin
result := TBitmap.Create;
result.SetSize(1920, 1080);
result.PixelFormat := pf24bit;
for y := 0 to result.Height - 1 do
begin
scanline := result.ScanLine[y];
for x := 0 to result.Width - 1 do
begin
if odd(x) then
scanline^ := WHITE
else
scanline^ := BLACK;
inc(scanline);
end;
end;
end;
Even cooler:
with scanline^ do
begin
rgbtBlue := Random(255);
rgbtGreen := Random(255);
rgbtRed := Random(255);
end;
To try it:
procedure TForm1.FormPaint(Sender: TObject);
var
bm: TBitmap;
begin
bm := CreateBitmapReallyFast;
try
Canvas.Draw(0, 0, bm);
finally
bm.Free;
end;
end;
Of course, if you have a (packed) array of TRGBTriple or TRGBQuad, and the pixel format of the bitmap is the same, you can simply Move the data in memory from the array to the bitmap's scanlines.
Is there a way to draw a transparent text on form that has some controls? If I use TLabel control, it would always show behind controls on the form.
You cannot use a TLabel control, since it is not a windowed control, and therefore it will be hidden by every windowed child control of the form. You could use a TStaticText, which is indeed a windowed control (a STATIC control), but it will be a bit difficult to make it truly transparent, I'd suppose.
You can use layered windows for this:
Create a new VCL project, and add a bunch of windowed controls to it.
Create a new form in the project, named splash. Set BorderStyle to bsNone, and set the font name, size, and colour to whatever you desire (e.g., Segoe UI, 42, red).
Add a public method
procedure Tsplash.UpdateSplash(const Str: string);
var
R: TRect;
P: TPoint;
S: TPoint;
bm: TBitmap;
bf: TBlendFunction;
EXSTYLE: DWORD;
x, y: integer;
pixel: PRGBQuad;
TextRed,
TextGreen,
TextBlue: byte;
begin
EXSTYLE := GetWindowLong(Handle, GWL_EXSTYLE);
SetWindowLong(Handle, GWL_EXSTYLE, EXSTYLE or WS_EX_LAYERED);
R := ClientRect;
bm := TBitmap.Create;
try
bm.PixelFormat := pf32bit;
bm.SetSize(ClientWidth, ClientHeight);
bm.Canvas.Brush.Color := clBlack;
bm.Canvas.FillRect(ClientRect);
bm.Canvas.Font.Assign(Self.Font);
bm.Canvas.Font.Color := clWhite;
DrawText(bm.Canvas.Handle, PChar(Str), Length(Str), R,
DT_SINGLELINE or DT_VCENTER or DT_CENTER or DT_WORD_ELLIPSIS);
TextRed := GetRValue(Font.Color);
TextGreen := GetGValue(Font.Color);
TextBlue := GetBValue(Font.Color);
for y := 0 to bm.Height - 1 do
begin
pixel := bm.ScanLine[y];
x := 0;
while x < bm.Width do
begin
with pixel^ do
begin
rgbReserved := (rgbRed + rgbGreen + rgbBlue) div 3;
rgbBlue := TextBlue * rgbReserved div 255;
rgbGreen := TextGreen * rgbReserved div 255;
rgbRed := TextRed * rgbReserved div 255;
end;
inc(pixel);
inc(x);
end;
end;
P := Point(0, 0);
S := Point(bm.Width, bm.Height);
bf.BlendOp := AC_SRC_OVER;
bf.BlendFlags := 0;
bf.SourceConstantAlpha := 255;
bf.AlphaFormat := AC_SRC_ALPHA;
UpdateLayeredWindow(Handle, 0, nil, #S, bm.Canvas.Handle, #P, 0, #bf,
ULW_ALPHA)
finally
bm.Free;
end;
end;
To your main form, add private methods
procedure TForm1.CreateSplash;
var
p: TPoint;
begin
splash.Visible := true;
UpdateSplash;
end;
procedure TForm1.UpdateSplash;
var
p: TPoint;
begin
if not (Assigned(splash) and splash.Visible) then Exit;
p := ClientToScreen(Point(0, 0));
splash.SetBounds(p.X, p.Y, ClientWidth, ClientHeight);
splash.UpdateSplash('Sample Text');
end;
and call UpdateSplash every time the form is moved or resized:
procedure TForm1.WMMove(var Message: TWMMove);
begin
UpdateSplash;
end;
procedure TForm4.FormResize(Sender: TObject);
begin
UpdateSplash;
end;
Finally, you can do, just to try it out,
procedure TForm1.FormClick(Sender: TObject);
begin
if splash.Visible then
splash.Hide
else
CreateSplash;
end;
Compiled demo EXE