Canvas.Font.Color 在某些 Font.Quality 设置上的输出不准确

Question

我有一个基于 TLabel 的自定义组件，它允许向标题添加彩色轮廓。这是完整的代码：

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.

这是一个输出示例，字体颜色为 clWhite、OutlineColor := clBlack, OutlineThickness := 1，所有轮廓均已启用，Font.Quality 其他，而非 fqAntiAliased 或 fqNonAntialiased.

部分线条呈现为绿色、紫色等。轮廓较粗，在大字体上不太明显，但黑色周围仍然有颜色"glow"。有什么方法可以在所有字体质量设置上获得颜色 "correct" 吗？

Answer 1

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

没有。

这与您的组件代码无关，颜色伪像是 ClearType 技术实现亚像素精度的方式 - 它利用了每个像素由三个水平颜色组件组成的事实。更多详情 here.

您可以通过 SystemParametersInfo 传递 (SPI_GETCLEARTYPE) 作为 uiAction 参数查询系统上是否开启了 ClearType。

"Draft"、"Default" 和 "Proof" 质量遵循任何使用的技术。

"ClearType"、"ClearTypeNatural"、"Antialiased"（灰度）和 "NonAntialiased"（黑白）质量不遵循系统范围的设置。根据您的要求（正确的颜色），唯一安全的选择是使用 NonAntialiased 字体质量。

此外，还有一些情况不使用 ClearType，例如，在 256 色显示器上，或使用 Type 1 字体。有关详细信息，请参阅 CreateFont 中的备注。

Canvas.Font.Color 在某些 Font.Quality 设置上的输出不准确

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

delphi

fonts

paint