I'm making several updates to the TIceTabSet (Chrome tabs) component. One of these changes is to add transparency. Everything works fine apart from the text. As the alpha channel of the background gets lower, the text becomes more and more blurred. Here's a screenshot.
Here's the code that draws the tabs. Most of it is the original TIceTabSet code. I've simply added a few changes to make the tabs transparent. The code has also been altered a little for the example screenshot. The DrawText command at the bottom is where the text is drawn to the canvas.
procedure TIceTabSet.InnerDraw(Canvas: TCanvas; TabRect: TRect; Item: TIceTab);
var
graphics : TGPGraphics;
Pen: TGPPen;
Brush: TGPSolidBrush;
path, linePath: TGPGraphicsPath;
linGrBrush: TGPLinearGradientBrush;
font: TGPFont;
solidBrush: TGPSolidBrush;
rectF: TGPRectF;
stringFormat: TGPStringFormat;
DC: HDC;
marginRight: integer;
iconY, iconX: integer;
textStart: Extended;
startColor, EndColor, textColor, borderColor: cardinal;
borderWidth: Integer;
TabProperties: TIceTabProperties;
Alpha: Byte;
begin
DC := Canvas.Handle;
TabProperties := GetTabProperties(Item);
Alpha := Item.Index * 50;
startColor := MakeGDIPColor(TabProperties.TabStyle.StartColor, Alpha);// TabProperties.TabStyle.Alpha);
endColor := MakeGDIPColor(TabProperties.TabStyle.StopColor, Alpha); //TabProperties.TabStyle.Alpha);
textColor := MakeGDIPColor(TabProperties.Font.Color, 255); //TabProperties.TabStyle.Alpha);
borderColor := MakeGDIPColor(TabProperties.BorderColor, TabProperties.TabStyle.Alpha);
borderWidth := TabProperties.BorderWidth;
graphics := TGPGraphics.Create(DC);
Brush := TGPSolidBrush.Create(borderColor);
Pen:= TGPPen.Create(borderColor);
Font := GetGDIPFont(Canvas, FTabActive.Font); //TabProperties.Font);
try
graphics.SetSmoothingMode(SmoothingModeHighQuality);
pen.SetWidth(borderWidth);
path := TGPGraphicsPath.Create();
try
path.AddBezier(TabRect.Left, TabRect.Bottom, TabRect.Left + FTabShape.LeftEdgeWidth / 2, TabRect.Bottom, TabRect.Left + FTabShape.LeftEdgeWidth / 2, TabRect.Top, TabRect.Left + FTabShape.LeftEdgeWidth, TabRect.Top);
path.AddLine(TabRect.Left + FTabShape.LeftEdgeWidth, TabRect.Top, TabRect.Right - FTabShape.RightEdgeWidth, TabRect.Top);
path.AddBezier(TabRect.Right - FTabShape.RightEdgeWidth, TabRect.Top, TabRect.Right - FTabShape.RightEdgeWidth / 2, TabRect.Top, TabRect.Right - FTabShape.RightEdgeWidth / 2, TabRect.Bottom, TabRect.Right, TabRect.Bottom);
linePath := TGPGraphicsPath.Create;
try
linePath.AddPath(path, false);
path.AddLine(TabRect.Right, TabRect.Bottom, TabRect.Left, TabRect.Bottom);
linGrBrush := TGPLinearGradientBrush.Create(
MakePoint(0, TabRect.Top),
MakePoint(0, TabRect.Bottom),
startColor,
endColor);
try
graphics.DrawPath(pen, linePath);
graphics.FillPath(linGrBrush, path);
finally
linGrBrush.Free;
end;
finally
linePath.Free;
end;
finally
path.Free;
end;
marginRight := 0;
if TabDisplaysCloseButton(Item) then
begin
if (HighLightTabClose = Item) and
(FTabCloseButton.ShowCircle) then
begin
pen.SetWidth(1);
pen.SetColor(MakeGDIPColor(FTabCloseButton.CrossColorHotTrack, 255));
brush.SetColor(MakeGDIPColor(FTabCloseButton.CircleColorHotTrack, 255));
graphics.FillEllipse(brush, TabRect.Right - FTabShape.RightEdgeWidth - 7 - 2,
TabRect.Top + ((TabRect.Bottom - TabRect.Top - 7) div 2) - 3,
(TabRect.Right - FTabShape.RightEdgeWidth) - (TabRect.Right - FTabShape.RightEdgeWidth - 7) + 6,
(TabRect.Top + ((TabRect.Bottom - TabRect.Top + 7) div 2)) - (TabRect.Top + ((TabRect.Bottom - TabRect.Top - 7) div 2)) + 6);
graphics.DrawLine(pen, TabRect.Right - FTabShape.RightEdgeWidth - 5, TabRect.Top + ((TabRect.Bottom - TabRect.Top - 5) div 2),
TabRect.Right - FTabShape.RightEdgeWidth, TabRect.Top + ((TabRect.Bottom - TabRect.Top + 5) div 2));
graphics.DrawLine(pen, TabRect.Right - FTabShape.RightEdgeWidth, TabRect.Top + ((TabRect.Bottom - TabRect.Top - 5) div 2),
TabRect.Right - FTabShape.RightEdgeWidth - 5, TabRect.Top + ((TabRect.Bottom - TabRect.Top + 5) div 2));
end
else
begin
pen.SetWidth(2);
if HighlightTabClose = Item then
pen.SetColor(MakeGDIPColor(FTabCloseButton.CrossColorHotTrack, 255))
else
pen.SetColor(MakeGDIPColor(FTabCloseButton.CrossColorNormal, 255));
graphics.DrawLine(pen, TabRect.Right - FTabShape.RightEdgeWidth - 7, TabRect.Top + ((TabRect.Bottom - TabRect.Top - 7) div 2),
TabRect.Right - FTabShape.RightEdgeWidth, TabRect.Top + ((TabRect.Bottom - TabRect.Top + 7) div 2));
graphics.DrawLine(pen, TabRect.Right - FTabShape.RightEdgeWidth, TabRect.Top + ((TabRect.Bottom - TabRect.Top - 7) div 2),
TabRect.Right - FTabShape.RightEdgeWidth - 7, TabRect.Top + ((TabRect.Bottom - TabRect.Top + 7) div 2));
end;
marginRight := 10;
end;
solidBrush:= TGPSolidBrush.Create(MakeGDIPColor(textColor, 255));
stringFormat:= TGPStringFormat.Create;
stringFormat.SetAlignment(StringAlignmentNear);
stringFormat.SetLineAlignment(StringAlignmentCenter);
stringFormat.SetTrimming(StringTrimmingEllipsisCharacter);
stringFormat.SetFormatFlags(StringFormatFlagsNoWrap);
SelectClipRgn(Canvas.Handle, 0);
textStart := TabRect.Left + FTabShape.LeftEdgeWidth;
iconX := 0;
iconY := 0;
if Assigned(Images) and (Item.ImageIndex <> -1) then
begin
iconY := TabRect.Top + ((TabRect.Bottom - TabRect.Top - Images.Height) div 2);
iconX := Round(textStart);
textStart := textStart + Images.Width + 4;
end;
rectF := MakeRect(textStart, TabRect.Top, TabRect.Right - textStart - FTabShape.RightEdgeWidth - marginRight,
TabRect.Bottom - TabRect.Top);
// ****** Text is drawn here *******
if rectF.Width > 10 then
graphics.DrawString(format('Alpha: %d', [Alpha]), -1, font, rectF, stringFormat, solidBrush);
// *********************************
finally
font.Free;
solidBrush.Free;
Pen.Free;
graphics.Free;
end;
if Assigned(Images) and
(Item.ImageIndex <> -1) then
Images.Draw(Canvas, iconX, iconY, Item.ImageIndex, true);
end;
You can download the full source here. Please be aware that this is a work in progress. The source will be submitted back to the original author when it is complete.
Update 1
Changing the code as TLama suggested certainly helps, but it doesn't completely fix the issue. Here's how the text looks now:
...here's how Google Chrome looks:
Update 2
Here's how it looks with TextRenderingHintSingleBitPerPixelGridFit.
I've tried all the options and TextRenderingHintAntiAlias gives the best results.
As an alternative, you can try drawing with the theme api (Vista and later). Playing with various shadow/border/glow settings, it may be possible to come up with readable text. Some tryout on sheet of glass:
code (XE2):
procedure TForm1.FormPaint(Sender: TObject);
var
R: TRect;
ThemeData: HTHEME;
Opts: TDTTOpts;
begin
R := Rect(10, 10, 150, 30);
vcl.themes.DrawGlassText(Canvas.Handle, 'DrawGlassText Sample', R, 0, 3,
clBlack, TStyleManager.SystemStyle.GetElementDetails(ttsLabel));
OffsetRect(R, 160, 0);
ThemeData := OpenThemeData(Handle, 'textstyle');
Opts.dwSize := SizeOf(Opts);
Opts.crText := ColorToRGB(clBlack);
Opts.crShadow := $D0D0B0;
Opts.iTextShadowType := TST_SINGLE;
Opts.ptShadowOffset := Point(1, 1);
Opts.fApplyOverlay := True;
Opts.iGlowSize := 3;
Opts.dwFlags := DTT_TEXTCOLOR or DTT_SHADOWTYPE or DTT_SHADOWCOLOR
or DTT_SHADOWOFFSET or DTT_GLOWSIZE;
DrawThemeTextEx(ThemeData, Canvas.Handle, TEXT_LABEL, TS_NORMAL,
'DrawThemeTextEx Sample', -1, 0, @R, Opts);
OffsetRect(R, 180, 0);
Opts.crText := ColorToRGB(clBlack);
Opts.iGlowSize := 4;
Opts.fApplyOverlay := True;
Opts.dwFlags := DTT_TEXTCOLOR or DTT_GLOWSIZE;
DrawThemeTextEx(ThemeData, Canvas.Handle, TEXT_BODYTITLE, 0,
'Another Sample', -1, 0, @R, Opts);
CloseThemeData(ThemeData);
end;
As Ian Boyd suggested in his nice post about How to draw ClearType text on Aero glass ?
you should apply antialising when you're rendering the text on a sheet of glass. So to fix your problem, try to modify your code this way:
if rectF.Width > 10 then
begin
if (GetParentForm.GlassFrame.Enabled) and (GetParentForm.GlassFrame.SheetOfGlass) then
graphics.SetTextRenderingHint(TextRenderingHintAntiAliasGridFit);
graphics.DrawString(Item.DisplayCaption, -1, font, rectF, stringFormat, solidBrush);
end;
To simulate your problem it's enough to just render the text on the sheet of Aero glass, like the following code does in a 3 different ways:
uses
GDIPAPI, GDIPOBJ;
procedure TForm1.FormCreate(Sender: TObject);
begin
Font.Color := clWhite;
GlassFrame.SheetOfGlass := True;
GlassFrame.Enabled := True;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
S: WideString;
GPFont: TGPFont;
GPGraphics: TGPGraphics;
GPSolidBrush: TGPSolidBrush;
GPGraphicsPath: TGPGraphicsPath;
begin
S := 'This is a sample text rendered on the sheet of Aero glass!';
GPFont := TGPFont.Create(Canvas.Handle, Font.Handle);
GPSolidBrush := TGPSolidBrush.Create(MakeColor(GetRValue(Font.Color),
GetGValue(Font.Color), GetBValue(Font.Color)));
GPGraphicsPath := TGPGraphicsPath.Create;
GPGraphicsPath.AddString(S, Length(S), TGPFontFamily.Create(Font.Name),
GPFont.GetStyle, GPFont.GetSize, MakePoint(20.0, 60.0), nil);
try
GPGraphics := TGPGraphics.Create(Canvas.Handle);
try
GPGraphics.SetSmoothingMode(SmoothingModeAntiAlias);
GPGraphics.FillPath(GPSolidBrush, GPGraphicsPath);
GPGraphics.DrawString(S, Length(S), GPFont, MakePoint(20.0, 20.0),
nil, GPSolidBrush);
GPGraphics.SetTextRenderingHint(
TextRenderingHintSingleBitPerPixelGridFit);
GPGraphics.DrawString(S, Length(S), GPFont, MakePoint(20.0, 40.0),
nil, GPSolidBrush);
finally
GPGraphics.Free;
end;
finally
GPFont.Free;
GPSolidBrush.Free;
GPGraphicsPath.Free;
end;
end;
And it results to the following image where:
DrawString
function without text antialiasing enabledDrawString
function with text antialiasing enabled, configured to the TextRenderingHintSingleBitPerPixelGridFit
modethis article
with the smoothing mode set to the SmoothingModeAntiAlias
styleIf you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With