I am looking to draw an opacity ellipse in CodeGear Delphi 2010.
I had tried to draw to an another bitmap,
I had set the bitmap transparent color(for background)
Call the ellipse method.
And in my image I draw the bitmap with opacity parameter(from overload). But it doesn't work.
I want something like this http://www.java2s.com/Tutorial/VBImages/WPF-UseOpacityMaskAndRadialGradientBrush.PNG
Does anybody know an working method?
It works for me:
procedure TForm1.Button1Click(Sender: TObject);
var
bm1, bm2: TBitmap;
begin
bm1 := TBitmap.Create;
bm1.LoadFromFile('C:\Users\Andreas Rejbrand\Pictures\portrait.bmp');
bm2 := TBitmap.Create;
bm2.SetSize(bm1.Width, bm1.Height);
bm2.Canvas.Brush.Color := clRed;
bm2.Canvas.Pen.Style := psClear;
bm2.Canvas.Ellipse(0, 0, bm2.Width, bm2.Height);
Canvas.Draw(100, 100, bm1);
Canvas.Draw(100, 100, bm2, 127);
end;
If you want more control, you can always do the processing manually:
procedure TForm1.Button1Click(Sender: TObject);
type
TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad)-1] of TRGBQuad;
PRGB32Array = ^TRGB32Array;
TScanline = TRGB32Array;
PScanline = ^TScanline;
var
bm1, bm2, bm3: TBitmap;
sc1, sc2, sc3: PScanline;
i: Integer;
j: Integer;
var
transp: real;
const
opacity = 0.29;
begin
transp := 1 - opacity;
bm1 := TBitmap.Create;
bm1.LoadFromFile('C:\Users\Andreas Rejbrand\Pictures\portrait.bmp');
bm2 := TBitmap.Create;
bm2.SetSize(bm1.Width, bm1.Height);
bm2.Canvas.Brush.Color := clRed;
bm2.Canvas.Pen.Style := psClear;
bm2.Canvas.Ellipse(0, 0, bm2.Width, bm2.Height);
bm3 := TBitmap.Create;
bm3.SetSize(bm1.Width, bm1.Height);
bm1.PixelFormat := pf32bit;
bm2.PixelFormat := pf32bit;
bm3.PixelFormat := pf32bit;
for i := 0 to bm1.Height - 1 do
begin
sc1 := bm1.ScanLine[i];
sc2 := bm2.ScanLine[i];
sc3 := bm3.ScanLine[i];
for j := 0 to bm1.Width - 1 do
with sc3^[j] do
begin
rgbBlue := round(transp*sc1^[j].rgbBlue + opacity*sc2^[j].rgbBlue);
rgbGreen := round(transp*sc1^[j].rgbGreen + opacity*sc2^[j].rgbGreen);
rgbRed := round(transp*sc1^[j].rgbRed + opacity*sc2^[j].rgbRed);
end;
end;
Canvas.Draw(100, 100, bm3);
end;
You can for example let the background image be at 100 % opacity outside the ellipse:
...
for i := 0 to bm1.Height - 1 do
begin
sc1 := bm1.ScanLine[i];
sc2 := bm2.ScanLine[i];
sc3 := bm3.ScanLine[i];
for j := 0 to bm1.Width - 1 do
if sc2^[j].rgbBlue + sc2^[j].rgbGreen + sc2^[j].rgbRed = 3*255 then
sc3^[j] := sc1^[j]
else
with sc3^[j] do
begin
rgbBlue := round(transp*sc1^[j].rgbBlue + opacity*sc2^[j].rgbBlue);
rgbGreen := round(transp*sc1^[j].rgbGreen + opacity*sc2^[j].rgbGreen);
rgbRed := round(transp*sc1^[j].rgbRed + opacity*sc2^[j].rgbRed);
end;
end;
...
Not to mention all other cool stuff you can do with pixmap manipulation:
...
for i := 0 to bm1.Height - 1 do
begin
sc1 := bm1.ScanLine[i];
sc2 := bm2.ScanLine[i];
sc3 := bm3.ScanLine[i];
for j := 0 to bm1.Width - 1 do
if sc2^[j].rgbBlue + sc2^[j].rgbGreen + sc2^[j].rgbRed = 3*255 then
sc3^[j] := sc1^[j]
else
with sc3^[j] do
begin
rgbBlue := round(sin(transp*sc1^[j].rgbBlue + opacity*sc2^[j].rgbBlue));
rgbGreen := round(transp*sc1^[j].rgbGreen + opacity*sc2^[j].rgbGreen);
rgbRed := round(transp*sc1^[j].rgbRed + opacity*sc2^[j].rgbRed);
end;
end;
...
If you really don't want to do it manually, I just figured out, you can draw the ellipse on a copy of the first bitmap, and then blend these two bitmaps:
procedure TForm1.Button1Click(Sender: TObject);
var
bm1, bm2: TBitmap;
begin
bm1 := TBitmap.Create;
bm1.LoadFromFile('C:\Users\Andreas Rejbrand\Pictures\portrait.bmp');
bm2 := TBitmap.Create;
bm2.LoadFromFile('C:\Users\Andreas Rejbrand\Pictures\portrait.bmp');
bm2.Canvas.Brush.Color := clRed;
bm2.Canvas.Pen.Style := psClear;
bm2.Canvas.Ellipse(0, 0, bm2.Width, bm2.Height);
Canvas.Draw(100, 100, bm1);
Canvas.Draw(100, 100, bm2, 127);
end;
Related
I use Delphi 6.0, and I have TPanel, that contains TVirtualStringTree, that contains many nodes (more, than 1 screen).
I need to save this panel (with all nodes) to the BMP as a picture.
I use this method to save panel:
procedure TfrmDidTreeTime.cmSaveGantClick(Sender: TObject);
var
bmp : tBitmap;
cnt : Integer;
Dc : HDC;
R : TRect;
begin
inherited;
DC := GetDC ( pnlChart.handle);
R := pnlChart.boundsRect;
bmp := tBitmap.create;
bmp.width := R.Right-R.Left;
bmp.Height := R.Bottom - R.Top;
Bitblt(bmp.canvas.handle,0,0,bmp.Width,bmp.height,dc,r.left,r.top,srccopy);
spdSaveGraph.DefaultExt := 'bmp';
spdSaveGraph.FileName := 'Gant.bmp';
spdSaveGraph.Filter := 'Bitmap Picture|*.bmp';
if spdSaveGraph.Execute then
bmp.saveToFile (spdSaveGraph.FileName);
bmp.free;
end;
But this method saves only nodes that shows on the screen, but I need to save all of nodes.
procedure TfrmDidTreeTime.cmSaveDidTreeTimeClick(Sender: TObject);
var
bmp_total: tBitmap;
bmp_current : tBitmap;
r: TRect;
dc: HDC;
date_start: TDateTime;
h: integer;
bmp_current_position: integer;
scroll_position_current: integer;
scroll_position_total: integer;
screen_count: integer;
begin
inherited;
date_start := dtpDateStart.Value;
dc := GetDC (tvDidTimeTree.handle);
r := tvDidTimeTree.boundsRect;
bmp_total := tBitmap.create;
bmp_total.width := r.Right - r.Left - sbxVertical.Width - 3;
h := r.Bottom - r.Top - tvDidTimeTree.Header.Height;
if h < 0 then
h := 0;
SendMessage(tvDidTimeTree.Handle, WM_VSCROLL, SB_BOTTOM, 0);
scroll_position_total := GetScrollPos(tvDidTimeTree.Handle, sb_Vert);
screen_count := round(scroll_position_total / h);
bmp_total.Height := h * (screen_count + 1);
bmp_current_position := 0;
SendMessage(tvDidTimeTree.Handle, WM_VSCROLL, SB_TOP, 0);
tvDidTimeTree.Repaint;
while (scroll_position_current < scroll_position_total) do
begin
r := tvDidTimeTree.boundsRect;
dc := GetDC (tvDidTimeTree.handle);
bmp_current := tBitmap.create;
bmp_current.width := r.Right - r.Left - sbxVertical.Width - 3;
bmp_current.Height := h - 5;
Bitblt(bmp_total.canvas.handle, 0, bmp_current_position, bmp_current.Width, bmp_current.height, dc, r.left, r.top, srccopy);
scroll_position_current := GetScrollPos(tvDidTimeTree.Handle, sb_Vert);
SendMessage(tvDidTimeTree.Handle, WM_VSCROLL, SB_PAGEDOWN, 0);
tvDidTimeTree.Repaint;
bmp_current_position := bmp_current_position + bmp_current.Height;
end;
spdSaveGraph.DefaultExt := 'bmp';
spdSaveGraph.FileName := DateToStr(date_start) + '—' + DateToStr(IncMonth(date_start, 1)) + '.bmp';
spdSaveGraph.Filter := 'Bitmap Picture|*.bmp';
if spdSaveGraph.Execute then
bmp_total.saveToFile (spdSaveGraph.FileName);
bmp_total.free;
end;
I am having trouble with printing string grid. I use this code which works good except brush style. In application it works - where in cell is 'XXXX', it is overwritten with brush.style:= bsDiagCross; But when I try to print it, brush style is gone and on printed page is table with 'XXXX'. What´s wrong?
procedure frmPrint.Gridd(grd:TStringGrid; links, oben: Integer; scal:double; farbig:boolean);
var
x, y, li, ob, re, un, waag, senk, a, vSpalte, bSpalte, vZeile, bZeile: integer;
fix, grund, schrift, Barva: TColor;
r: TRect;
RR: TRect;
Sirka,Vyska, Velikost : integer;
function rech(i,j:integer):integer;
begin
result:=round(((i*j) / 72) * scal);
end;
begin
if printdialog.execute then // offnet den print dialog
begin
vZeile := 0;
vSpalte := 0;
Sirka := Printer.PageWidth;
Vyska := Printer.PageHeight;
bZeile := grd.rowcount - 1;
bSpalte := grd.colcount - 1;
if (scal > 0) and
(vZeile < grd.rowcount) and
(vSpalte < grd.colcount) then
begin
if farbig then
begin
fix := grd.fixedcolor;
grund := grd.color;
schrift := grd.font.color;
end
else
begin
fix := clsilver;
grund := clwhite;
schrift := clblack;
end;
waag := GetDeviceCaps(Printer.Handle, LogPixelSX);
senk := GetDeviceCaps(Printer.Handle, LogPixelSY);
links := rech(links, waag);
oben := rech(oben, senk);
li := GetDeviceCaps(Printer.Handle, PhysicalOffsetX) + 1 + links;
a := rech(3, waag);
with Printer do
begin
Title := 'report';
Orientation := poLandscape; //poLandscape;
BeginDoc;
if grd.gridlinewidth > 0 then
begin
Canvas.Pen.color := $333333;
Canvas.Pen.width := 1;
Canvas.Pen.Style := psSolid
end
else
Canvas.Pen.Style := psClear;
Canvas.Font := Grd.Font;
Canvas.Font.Color := Schrift;
Canvas.Font.Size := round((Grd.Font.Size / 0.72) * scal);
ob := GetDeviceCaps(Printer.Handle, PhysicalOffsetY) + 1 + oben;
for y := vZeile to bZeile do
begin
un := ob + rech(Grd.RowHeights[y]+1, senk);
//neue Seite + Kopf
if (un > Printer.PageHeight) and
(Printing) then
begin
EndDoc;
BeginDoc;
ob := GetDeviceCaps(Printer.Handle, PhysicalOffsetY) + 1 + oben;
un := ob + rech(Grd.RowHeights[y]+1, senk);
for x := vSpalte to bSpalte do
begin
Canvas.Brush.Color := fix;
re := li + rech(Grd.ColWidths[x] + 1, waag);
Canvas.Rectangle(li, ob, re + 2, un + 2);
r := rect(li + a, ob + 1, re - a, un - 2);
DrawText(Canvas.Handle, PChar(Grd.Cells[x,0]), length(Grd.Cells[x,0]), r, DT_SINGLELINE or DT_VCENTER);
li := re;
end;
li := GetDeviceCaps(Printer.Handle, PhysicalOffsetX) + 1 + links;
ob := un;
end;
un := ob + rech(Grd.RowHeights[y]+1, senk);
for x := vSpalte to bSpalte do
begin
if (x < Grd.FixedCols) or
(y < Grd.FixedRows) then
Canvas.Brush.Color := fix
else
Canvas.Brush.Color := Grund;
re := li + rech(Grd.ColWidths[x]+ 1, waag);
Canvas.Rectangle(li, ob, re + 2, un + 2);
r := rect(li + a, ob + 1, re - a, un - 2);
DrawText(Canvas.Handle, PChar(Grd.Cells[x,y]), length(Grd.Cells[x,y]), r, DT_SINGLELINE or DT_VCENTER);
li := re;
end;
ob := un;
li := GetDeviceCaps(Printer.Handle, PhysicalOffsetX) + 1 + links;
end;
if Printing then
EndDoc;
end;
end;
end;
end;
procedure frmPrint.sgDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect;
State: TGridDrawState);
var
sg : TStringGrid;
c : TCanvas;
begin
sg := TStringGrid( Sender );
c := sg.Canvas;
if // Zellen
( sg.Cells[ACol,ARow] = 'XXXX' )
then begin
c.Brush.Style := bsDiagCross;
c.FillRect(Rect);
// c.Brush.Color := clblack;
end;
sg.Canvas.Pen.Color := clblack;
// "Set the Style property to bsClear to eliminate flicker when the object
// repaints" (I don't know if this helps).
sg.Canvas.Brush.Style := bsClear;
// Draw a line from the cell's top-right to its bottom-right:
sg.Canvas.MoveTo(Rect.Right, Rect.Top);
sg.Canvas.LineTo(Rect.Right, Rect.Bottom);
// Make the horizontal line.
sg.Canvas.LineTo(Rect.Left, Rect.Bottom);
// The other vertical line.
sg.Canvas.LineTo(Rect.Left, Rect.Top);
zmeneno:= false;
end;
In the printing code (frmPrint.Gridd()) you are missing the check for 'XXXX' and corresponding setting of Brush.Style and call to FillRect() instead of the call to DrawText().
In frmPrint.Gridd() in the second for x loop change this line:
DrawText(Canvas.Handle, PChar(grd.Cells[x, y]), length(grd.Cells[x, y]), r,
DT_SINGLELINE or DT_VCENTER);
to (untested):
if grd.Cells[x, y] = 'XXXX' then
begin
Canvas.Brush.Style := bsDiagCross;
Canvas.FillRect(r);
Canvas.Brush.Style := bsClear;
end
else
begin
DrawText(Canvas.Handle, PChar(grd.Cells[x, y]), length(grd.Cells[x, y]), r,
DT_SINGLELINE or DT_VCENTER);
end;
If the header row also may have those 'XXXX' cells then do the corresponding change also in the first for x loop.
Tom, thank you very much for your help!!
Solution is to swap the brush block behind draw
This works perfectly:
...
DrawText(Canvas.Handle, PChar(Grd.Cells[x,y]), length(Grd.Cells[x,y]), r, DT_SINGLELINE or DT_VCENTER);
li := re;
if grd.Cells[x, y] = 'XXXX' then
begin
Canvas.Brush.Style := bsDiagCross;
Canvas.FillRect(r);
Canvas.Brush.Style := bsClear;
end;
I would like to know if it is possible to make the Form transparent (AlphaBlend) without the Border (where the minimize button is and all that) being transparent too? If it is, how can I do it?
It is possible, but any controls you put on such form will not be visible.
Here is some base code to get you started, but I have never used it on forms with border, so there might be possible issues with border functionality. Most likely, you will have to create bitmap that will include window border and set alpha for that part to 255;
procedure PremultiplyBitmap(Bitmap: TBitmap);
var
Row, Col: Integer;
p: PRGBQuad;
begin
Bitmap.AlphaFormat := afPremultiplied;
for Row := 0 to Bitmap.Height - 1 do
begin
Col := Bitmap.Width;
p := Bitmap.ScanLine[Row];
while (Col > 0) do
begin
p.rgbBlue := p.rgbReserved * p.rgbBlue div 255;
p.rgbGreen := p.rgbReserved * p.rgbGreen div 255;
p.rgbRed := p.rgbReserved * p.rgbRed div 255;
inc(p);
dec(Col);
end;
end;
end;
procedure PremultiplyBitmapAlpha(Bitmap: TBitmap; Alpha: byte);
var
Row, Col: Integer;
p: PRGBQuad;
begin
Bitmap.AlphaFormat := afPremultiplied;
for Row := 0 to Bitmap.Height - 1 do
begin
Col := Bitmap.Width;
p := Bitmap.ScanLine[Row];
while (Col > 0) do
begin
p.rgbReserved := Alpha;
p.rgbBlue := p.rgbReserved * p.rgbBlue div 255;
p.rgbGreen := p.rgbReserved * p.rgbGreen div 255;
p.rgbRed := p.rgbReserved * p.rgbRed div 255;
inc(p);
dec(Col);
end;
end;
end;
procedure BlendForm(Form: TCustomForm; Bmp: TBitmap);
var
BitmapPos: TPoint;
BitmapSize: TSize;
BlendFunction: TBlendFunction;
begin
BitmapPos := Point(0, 0);
BitmapSize.cx := Bmp.Width;
BitmapSize.cy := Bmp.Height;
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.BlendFlags := 0;
BlendFunction.SourceConstantAlpha := 255;
BlendFunction.AlphaFormat := AC_SRC_ALPHA;
UpdateLayeredWindow(Form.Handle, 0, nil, #BitmapSize, Bmp.Canvas.Handle, #BitmapPos, 0, #BlendFunction, ULW_ALPHA);
end;
procedure TForm1.CreateWnd;
var
ExStyle: DWORD;
begin
inherited;
ExStyle := GetWindowLong(Handle, GWL_EXSTYLE);
if (ExStyle and WS_EX_LAYERED = 0) then
SetWindowLong(Handle, GWL_EXSTYLE, ExStyle or WS_EX_LAYERED);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
try
Bmp.PixelFormat := pf32bit;
Bmp.Width := ClientWidth;
Bmp.Height := ClientHeight;
PremultiplyBitmapAlpha(Bmp, 200);
BlendForm(Form1, Bmp);
finally
Bmp.Free;
end;
end;
Bitmaps you use have to be 32-bit bitmaps. If you want to blend whole bitmap with some alpha value, you can use PremultiplyBitmapAlpha procedure, and if your bitmap has alpha channel you can then use PremultiplyBitmap procedure.
For speed improvements you can use premultiplied byte table like this:
var
PreMult: array[byte, byte] of byte;
procedure InitializePreMult;
var
Row, Col: Integer;
begin
// precalculate all possible values of a*b
for Row := 0 to 255 do
for Col := Row to 255 do
PreMult[Row, Col] := Row*Col div 255;
end;
and then PremultiplyBitmap procedure would use that lookup table:
procedure PremultiplyBitmap(Bitmap: TBitmap);
var
Row, Col: integer;
p: PRGBQuad;
begin
for Row := 0 to Bitmap.Height-1 do
begin
Col := Bitmap.Width;
p := Bitmap.ScanLine[Row];
while (Col > 0) do
begin
p.rgbBlue := PreMult[p.rgbReserved, p.rgbBlue];
p.rgbGreen := PreMult[p.rgbReserved, p.rgbGreen];
p.rgbRed := PreMult[p.rgbReserved, p.rgbRed];
inc(p);
dec(Col);
end;
end;
end;
How can I replace color on TCanvas on Delphi XE2? The following code works incredibly slow:
for y := ARect.Top to ARect.Top + ARect.Height - 1 do
for x := ARect.Left to ARect.Left + ARect.Width - 1 do
if Canvas.Pixels[x, y] = FixedColor then
Canvas.Pixels[x, y] := Canvas.Pixels[ARect.Left, ARect.Top];
Here are two function (with and without tolerance) to replace the color:
Bonus:
Code to test the functions also provided. Load your image in a TImage control, then use the MouseUp event to change the color under mouse.
procedure ReplaceColor(BMP: TBitmap; OldColor, NewColor: TColor);
VAR
x, y: Integer;
R,G,B: Byte;
R_,G_,B_: Byte;
aPixel: PRGBTriple;
begin
R:= GetRValue(OldColor);
G:= GetGValue(OldColor);
B:= GetBValue(OldColor);
R_:= GetRValue(NewColor);
G_:= GetGValue(NewColor);
B_:= GetBValue(NewColor);
BMP.PixelFormat := pf24bit;
for y := 0 to BMP.Height - 1 do
for x := 0 to BMP.Width - 1 do
begin
aPixel := BMP.ScanLine[y];
Inc(aPixel, x);
if (aPixel^.rgbtRed = R)
AND (aPixel^.rgbtGreen = G)
AND (aPixel^.rgbtBlue = B) then
begin
aPixel^.rgbtRed := R_;
aPixel^.rgbtGreen := G_;
aPixel^.rgbtBlue := B_;
end;
end;
end;
procedure ReplaceColor(BMP: TBitmap; OldColor, NewColor: TColor; ToleranceR, ToleranceG, ToleranceB: Byte);
VAR
x, y: Integer;
R,G,B: Byte;
R_,G_,B_: Byte;
aPixel: PRGBTriple;
begin
R:= GetRValue(OldColor);
G:= GetGValue(OldColor);
B:= GetBValue(OldColor);
R_:= GetRValue(NewColor);
G_:= GetGValue(NewColor);
B_:= GetBValue(NewColor);
BMP.PixelFormat := pf24bit;
for y := 0 to BMP.Height - 1 do
for x := 0 to BMP.Width - 1 do
begin
aPixel := BMP.ScanLine[y];
Inc(aPixel, x);
if (abs(aPixel^.rgbtRed - R)< ToleranceR)
AND (abs(aPixel^.rgbtGreen- G)< ToleranceG)
AND (abs(aPixel^.rgbtBlue - B)< ToleranceB) then
begin
aPixel^.rgbtRed := R_;
aPixel^.rgbtGreen := G_;
aPixel^.rgbtBlue := B_;
end;
end;
end;
procedure TfrmTester.imgOnMouseUp(Sender: TObject; Shift: TShiftState; X, Y: Integer);
VAR
PixelClr: TColor;
BMP: TBitmap;
begin
// Collect the new color, under mouse pointer
PixelClr:= imgReplaceOrig.Picture.Bitmap.Canvas.Pixels[x, y];
if PixelClr< 0 then EXIT;
Label1.Caption := 'x'+IntToStr(X)+':y='
+ IntToStr(Y)
+' r'+ IntToStr(GetRValue(Pixel))
+', g'+ IntToStr(GetGValue(Pixel))
+', b'+ IntToStr(GetBValue(Pixel));
BMP:= TBitmap.Create;
BMP.Assign(imgReplaceOrig.Picture.Bitmap);
// Replace the color
cGraphUtil.ReplaceColor(BMP, PixelClr, clBlue, 44, 44, 44);
imgReplace.Picture.Assign(BMP);
FreeAndNil(BMP);
end;
var
aBitmap: TBitmap;
x, y: Integer;
aPixel: PRGBTriple;
...
aBitmap := TBitmap.Create;
try
aBitmap.PixelFormat := pf24bit;
aBitmap.Height := ARect.Height;
aBitmap.Width := ARect.Width;
aBitmap.Canvas.CopyRect(TRect.Create(0, 0, aBitmap.Width, aBitmap.Height), Canvas, ARect);
for y := 0 to aBitmap.Height - 1 do
for x := 0 to aBitmap.Width - 1 do
begin
aPixel := aBitmap.ScanLine[y];
Inc(aPixel, x);
if (aPixel^.rgbtRed = GetRValue(FixedColor)) and (aPixel^.rgbtGreen = GetGValue(FixedColor)) and (aPixel^.rgbtBlue = GetBValue(FixedColor)) then
aPixel^ := PRGBTriple(aBitmap.ScanLine[y])^;
end;
Canvas.Draw(ARect.Left, ARect.Top, aBitmap);
finally
aBitmap.Free;
end;
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