Inaccurate output of Canvas.Font.Color on certain Font.Quality settings

Question

I have a custom component, based on TLabel, that allows to add a colored outline to the caption. Here is the whole code:

unit OutlineLabel;

interface

uses
  System.SysUtils, System.Classes, Vcl.Controls,
  Windows, Messages, Variants, Graphics, Forms,
  Dialogs, StdCtrls;

type
  TOutline = (olTopLeft, olTopRight, olBottomLeft, olBottomRight);

type
  TOutlines = set of TOutline;

type
  TOutlineLabel = class(TLabel)
  private
    FOutlineColor : TColor;
    FOutlineTh    : word;
    FOutlines     : TOutlines;
    procedure DoDrawText(var Rect: TRect; Flags: Word);
  protected
    procedure Paint; override;
    procedure SetOutlineColor(Value : TColor);
    procedure SetOutlineTh(Thickness: word);
    procedure SetOutlines(Ols: TOutlines);
  public
    constructor Create(AOwner : TComponent); override;
  published
    property OutlineColor     : TColor read FOutlineColor write SetOutlineColor default clWhite;
    property OutlineThickness : word read FOutlineTh write SetOutlineTh default 1;
    property Outlines         : TOutlines read FOutlines write SetOutlines;
  end;

procedure Register;

implementation

constructor TOutlineLabel.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FOutlineColor   := clWhite;
end;

procedure TOutlineLabel.SetOutlineColor(Value : TColor);
begin
  if Value <> FOutlineColor then
  begin
    FOutlineColor := Value;
    Invalidate;
  end;
end;

procedure TOutlineLabel.SetOutlines(Ols: TOutlines);
begin
  if Ols <> FOutlines then
  begin
    FOutlines     := Ols;
    Invalidate;
  end;
end;

procedure TOutlineLabel.SetOutlineTh(Thickness: word);
begin
  if Thickness <> FOutlineTh then
  begin
    FOutlineTh    := Thickness;
    Invalidate;
  end;
end;

procedure TOutlineLabel.DoDrawText(var Rect : TRect; Flags : Word);
  var
    Text       : array[ 0..255 ] of Char;
    TmpRect    : TRect;
  begin
    GetTextBuf(Text, SizeOf(Text));
    if (Flags and DT_CALCRECT <> 0) and
       ((Text[0] = #0) or ShowAccelChar and
         (Text[0] = '&') and
         (Text[1] = #0)) then
      StrCopy(Text, ' ');

    if not ShowAccelChar then
          Flags := Flags or DT_NOPREFIX;
    Canvas.Font := Font;

    if olBottomRight In FOutlines then
    begin
      TmpRect           := Rect;
      OffsetRect(TmpRect, FOutlineTh, FOutlineTh);
      Canvas.Font.Color := OutlineColor;
      DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);
    end;

    if olTopLeft In FOutlines then
    begin
      TmpRect           := Rect;
      OffsetRect(TmpRect, FOutlineTh * -1, FOutlineTh * -1);
      Canvas.Font.Color := OutlineColor;
      DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);
    end;

    if olBottomLeft In FOutlines then
    begin
      TmpRect           := Rect;
      OffsetRect(TmpRect, FOutlineTh * -1, FOutlineTh);
      Canvas.Font.Color := OutlineColor;
      DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);
    end;

    if olTopRight In FOutlines then
    begin
      TmpRect           := Rect;
      OffsetRect(TmpRect, FOutlineTh, FOutlineTh * -1);
      Canvas.Font.Color := OutlineColor;
      DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);
    end;

    Canvas.Font.Color   := Font.Color;
    if not Enabled then
      Canvas.Font.Color := clGrayText;
    DrawText(Canvas.Handle, Text, StrLen(Text), Rect, Flags);
  end;


  procedure TOutlineLabel.Paint;
  const
    Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  var
    Rect: TRect;
  begin
    with Canvas do
    begin
      if not Transparent then
      begin
        Brush.Color := Self.Color;
        Brush.Style := bsSolid;
        FillRect(ClientRect);
      end;
      Brush.Style   := bsClear;
      Rect          := ClientRect;
      DoDrawText(Rect, (DT_EXPANDTABS or DT_WORDBREAK) or
                  Alignments[ Alignment ]);
    end;
  end;

  procedure Register;
  begin
    RegisterComponents('Standard', [TOutlineLabel]);
  end;


end.

Here is an example of an output, with font color clWhite, OutlineColor := clBlack, OutlineThickness := 1, all outlines enabled and Font.Quality other, than fqAntiAliased or fqNonAntialiased.

Some of the lines appears as green, purple etc. With thicker outline, it is less significant on large font sizes, but the black still has colored "glow" around. Is there some way to get the color "correct" on all font quality settings?

Answer 1

Is there some way to get the color "correct" on all font quality settings?

No.

This is not related with your component code, the color artifacts are how ClearType technology achieves sub-pixel accuracy - it makes use of the fact that each pixel is composed of three horizontal color components. More details here.

You can query if ClearType is turned on a system with SystemParametersInfo passing (SPI_GETCLEARTYPE) as uiAction parameter.

"Draft", "Default" and "Proof" qualities follow whatever technology is in use.

"ClearType", "ClearTypeNatural", "Antialiased" (grayscale) and "NonAntialiased" (black-white) qualities do not follow the system wide setting. Depending on your requirement (correct color) the only safe option is to use NonAntialiased font quality.

Additionally there are cases where ClearType is not used, for instance, on a 256 color display, or with Type 1 fonts. See remarks in CreateFont for more details.