Delphi 某些字体质量设置上Canvas.Font.Color的输出不准确

我有一个基于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.

单元大纲标签；
接口
使用
System.SysUtils、System.Classes、Vcl.Controls、，
窗口、消息、变体、图形、表单、，
对话框，stdctrl；
类型
TOutline=（oltoplft、oltoplight、olBottomLeft、olBottomRight）；
类型
TOutlines=一组TOutline；
类型
TOutlineLabel=类（TLabel）
私有的
FOutlineColor:TColor；
第四：单词；
FOutlines：TOutlines；
过程DoDrawText（变量Rect:TRect；标志：Word）；
受保护的
程序漆；推翻
程序SetOutlineColor（值：TColor）；
程序设置大纲（厚度：word）；
程序设置大纲（Ols：TOutlines）；
公众的
构造函数创建（AOwner:TComponent）；推翻
出版
属性OutlineColor:t颜色读取FOutlineColor写入设置OutlineColor默认值clWhite；
属性OutlineThickness:word read FOutlineTh write SetOutlineTh default 1；
属性大纲：TOutlines读取FOutlines写入SetOutlines；
结束；
程序登记册；
实施
构造函数TOutlineLabel.Create（所有者：TComponent）；
开始
继承的创建（AOOwner）；
FOutlineColor:=clWhite；
结束；
程序TOutlineLabel.SetOutlineColor（值：TColor）；
开始
如果值为FOutlineColor，则
开始
FOutlineColor:=值；
使无效
结束；
结束；
程序TOutlineLabel.SetOutlines（Ols:TOutlines）；
开始
如果Ols犯规，那么
开始
Foutline:=Ols；
使无效
结束；
结束；
程序TOutlineLabel.SetOutlineTh（厚度：word）；
开始
如果厚度过大，则
开始
FOutlineTh:=厚度；
使无效
结束；
结束；
过程TOutlineLabel.DoDrawText（变量Rect:TRect；标志：Word）；
变量
Text：字符的数组[0..255]；
TmpRect:TRect；
开始
GetTextBuf（Text，SizeOf（Text））；
if（标志和DT_校准0）和
（（文本[0]=#0）或ShowAccelChar和
（文本[0]=“&”）和
（文本[1]=#0））然后
StrCopy（文本“”）；
如果没有，那么
标志：=标志或DT_NOPREFIX；
Canvas.Font:=字体；
如果你在罚球线上打对了，那么
开始
TmpRect:=Rect；
偏置（TmpRect、FOutlineTh、FOutlineTh）；
Canvas.Font.Color:=大纲颜色；
DrawText（Canvas.Handle、Text、StrLen（Text）、TmpRect、Flags）；
结束；
如果olTopLeft在foutline中，那么
开始
TmpRect:=Rect；
偏置（TmpRect，FOutlineTh*-1，FOutlineTh*-1）；
Canvas.Font.Color:=大纲颜色；
DrawText（Canvas.Handle、Text、StrLen（Text）、TmpRect、Flags）；
结束；
如果你在罚球线上左下角，那么
开始
TmpRect:=Rect；
偏置（TmpRect，FOutlineTh*-1，FOutlineTh）；
Canvas.Font.Color:=大纲颜色；
DrawText（Canvas.Handle、Text、StrLen（Text）、TmpRect、Flags）；
结束；
如果OLT在Foutline中正确，则
开始
TmpRect:=Rect；
偏置（TmpRect、FOutlineTh、FOutlineTh*-1）；
Canvas.Font.Color:=大纲颜色；
DrawText（Canvas.Handle、Text、StrLen（Text）、TmpRect、Flags）；
结束；
Canvas.Font.Color:=Font.Color；
如果未启用，则
Canvas.Font.Color:=clGrayText；
DrawText（Canvas.Handle、Text、StrLen（Text）、Rect、Flags）；
结束；
标记油漆的程序；
常数
对齐：单词=（左、右、中）的数组[TAlignment]；
变量
Rect:TRect；
开始
用帆布做
开始
如果不是透明的话
开始
画笔颜色：=自身颜色；
画笔样式：=bsSolid；
FillRect（ClientRect）；
结束；
画笔样式：=b画笔；
Rect:=ClientRect；
DoDrawText（Rect，（DT_EXPANDTABS或DT_WORDBREAK）或
对齐[对齐]；
结束；
结束；
程序登记册；
开始
注册表组件（‘标准’，[TOutlineLabel]）；
结束；
结束。

这里是一个输出示例，字体颜色

clWhite

，

OutlineColor:=clBlack，OutlineThickness:=1

，所有轮廓均已启用，且

font.Quality

除

fqAntiAliased

或

FQNonAnentialiased

外，其他

一些线条显示为绿色、紫色等，轮廓较粗，在大字体上不太明显，但黑色的周围仍有彩色的“发光”。有没有办法在所有字体质量设置上获得“正确”的颜色

有没有办法让所有字体的颜色都“正确”呢 设置

没有

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

您可以查询ClearType是否在系统上打开，并将（

SPI\u GETCLEARTYPE

）作为

uiAction

参数传递

无论使用何种技术，“草稿”、“默认”和“证明”质量都会遵循

“ClearType”、“ClearTypeNatural”、“抗锯齿”（灰度）和“非本质”（黑白）质量不符合系统范围的设置。根据您的要求（正确的颜色），唯一安全的选择是使用非本质字体质量

---

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

您不需要组件来演示这一点，请在白色面板上放置标签，并将其字体大小设置为较大，颜色设置为黑色，质量设置为清晰类型。用放大镜或类似物检查。这就是操作系统如何绘制、使用抗锯齿等。。如果你不喜欢它。@SertacAkyuz如果这是我唯一的选择，那么是的，我将不得不将字体质量的选择限制为

FQantialased

和

fqNonAntialiased

，因为我想要