有没有办法在具有某些控件的表单上绘制透明文本?如果我使用TLabel
控件,它总是显示在窗体上的控件后面。
您不能使用TLabel
控件,因为它不是窗口控件,因此它将被窗体的每个窗口子控件隐藏。你可以使用TStaticText
,这确实是一个窗口控件(STATIC
控制),但我认为要使其真正透明会有点困难。
您可以为此使用分层窗口:
创建一个新的 VCL 项目,并向其中添加一堆窗口控件。
在项目中新建一个表单,命名为splash
. Set BorderStyle
to bsNone
,并将字体名称、大小和颜色设置为您想要的任何内容(例如,Segoe UI、42、红色)。
-
添加公共方法
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;
-
在您的主窗体中,添加私有方法
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;
并打电话UpdateSplash
每次移动或调整表单大小时:
procedure TForm1.WMMove(var Message: TWMMove);
begin
UpdateSplash;
end;
procedure TForm4.FormResize(Sender: TObject);
begin
UpdateSplash;
end;
最后,你可以尝试一下,
procedure TForm1.FormClick(Sender: TObject);
begin
if splash.Visible then
splash.Hide
else
CreateSplash;
end;
编译演示EXE
本文内容由网友自发贡献,版权归原作者所有,本站不承担相应法律责任。如您发现有涉嫌抄袭侵权的内容,请联系:hwhale#tublm.com(使用前将#替换为@)