Шрифты в Windows XP и Windows Vista/7

Написал небольшую программку, показывающую настройки шрифтов - может кому пригодится.

Код

procedure TForm1.FormCreate(Sender: TObject);

  procedure RenderFont(const AFont: TFont; const ADescription: String);

    function FindSubstitute(const AFontName: String; const ACharset: Integer): String;

      function StripCharset(const AFontName: String): String;
      var
        X: Integer;
      begin
        X := Pos(',', AFontName);
        if X > 0 then
          Result := Trim(Copy(AFontName, 1, X - 1))
        else
          Result := AFontName;
      end;

    var
      Reg: TRegIniFile;
    begin
      Reg := TRegIniFile.Create(KEY_READ);
      try
        Reg.RootKey := HKEY_LOCAL_MACHINE;
        if Reg.OpenKey('\SOFTWARE\Microsoft\Windows NT\CurrentVersion\FontSubstitutes', False) then
        begin
          if Reg.ValueExists(AFontName + ',' + IntToStr(ACharset)) then
            Result := StripCharset(Reg.ReadString('', AFontName + ',' + IntToStr(ACharset), AFontName))
          else
          if Reg.ValueExists(AFontName + ',0') then
            Result := StripCharset(Reg.ReadString('', AFontName + ',0', AFontName))
          else
          if Reg.ValueExists(AFontName) then
            Result := StripCharset(Reg.ReadString('', AFontName, AFontName))
          else
            Result := AFontName;
        end
        else
          Result := AFontName;
      finally
        FreeAndNil(Reg);
      end;
    end;

  const
    Line = '%s:'#9#9'%s (%s),'#9#9'%d, %d, DPI: %d, charset: %d, pitch: %d, quality: %d, orientation: %d';
  begin
    Memo1.Lines.Add(Format(Line, [ADescription, AFont.Name,
                                  FindSubstitute(AFont.Name, Ord(AFont.Charset)),
                                  AFont.Size, AFont.Height,
                                  Ord(AFont.PixelsPerInch), Ord(AFont.Charset),
                                  Ord(AFont.Pitch), Ord(AFont.Quality),
                                  Ord(AFont.Orientation)]));
  end;

  procedure RenderStockFont(const AStackFont: Integer; const ADescription: String);
  var
    Font: TFont;
  begin
    Font := TFont.Create;
    try
      Font.Handle := GetStockObject(AStackFont);
      RenderFont(Font, ADescription);
    finally
      FreeAndNil(Font);
    end;
  end;

  procedure RenderLogFont(const ALogFont: TLogFont; const ADescription: String);
  var
    Font: TFont;
  begin
    Font := TFont.Create;
    try
      Font.Handle := CreateFontIndirect(ALogFont);
      RenderFont(Font, ADescription);
    finally
      FreeAndNil(Font);
    end;
  end;

var
  Metrics: TNonClientMetrics;
begin
  Memo1.Lines.Clear;

  RenderStockFont(ANSI_FIXED_FONT, 'ANSI_FIXED_FONT');
  RenderStockFont(ANSI_VAR_FONT, 'ANSI_VAR_FONT');
  RenderStockFont(DEVICE_DEFAULT_FONT, 'DEVICE_DEFAULT_FONT');
  RenderStockFont(DEFAULT_GUI_FONT, 'DEFAULT_GUI_FONT');
  RenderStockFont(OEM_FIXED_FONT, 'OEM_FIXED_FONT');
  RenderStockFont(SYSTEM_FONT, 'SYSTEM_FONT');
  RenderStockFont(SYSTEM_FIXED_FONT, 'SYSTEM_FIXED_FONT');

  FillChar(Metrics, SizeOf(Metrics), 0);
  Metrics.cbSize := Metrics.SizeOf; // := SizeOf(Metrics); - для старых Delphi
  if not SystemParametersInfo(SPI_GETNONCLIENTMETRICS, Metrics.cbSize, @Metrics, 0) then
    RaiseLastOSError;

  RenderLogFont(Metrics.lfCaptionFont, 'CaptionFont');
  RenderLogFont(Metrics.lfSmCaptionFont, 'SmCaptionFont');
  RenderLogFont(Metrics.lfMenuFont, 'MenuFont');
  RenderLogFont(Metrics.lfStatusFont, 'StatusFont');
  RenderLogFont(Metrics.lfMessageFont, 'MessageFont');
end;

Историческая справка
Среди других вещей, которые вы можете запросить с помощью функции GetStockObject, есть два шрифта, называемые SYSTEM_FONT и DEFAULT_GUI_FONT. Что это такое?

Это шрифты, которые сегодня уже никем не используются.

В старые-добрые времена Windows 2.0, шрифт, используемый для диалоговых окон, был растровым шрифтом, называемым System. Это и есть шрифт, который возвращает SYSTEM_FONT, и он же всё ещё является шрифтом по-умолчанию для диалогов по соображениям совместимости. Конечно же, никто сегодня не будет использовать для своих диалогов такой ужасный шрифт (помимо прочих вещей - он растровый, и поэтому плохо выглядит на высоких разрешениях и не может быть сглажен).

История DEFAULT_GUI_FONT ещё менее примечательна. Он был создан во время разработки Windows 95 в надежде, что он станет новым шрифтом по-умолчанию для GUI, но в Июле 1994 Windows сама перестала его использовать, предпочитая ему шрифты, возвращаемые функцией SystemParametersInfo. Его существование теперь рудиментарное.

Ну и самое интересное:

Шрифты в XP

(DPI экрана был 96)

ANSI_FIXED_FONT:        Courier (Courier New),                  -9, 12, DPI: 96, charset: 0, pitch: 2
ANSI_VAR_FONT:          MS Sans Serif (MS Sans Serif),          -9, 12, DPI: 96, charset: 0, pitch: 1
DEVICE_DEFAULT_FONT:    System (System),                        -12, 16, DPI: 96, charset: 204, pitch: 1
DEFAULT_GUI_FONT:       MS Shell Dlg (Microsoft Sans Serif),    8, -11, DPI: 96, charset: 204, pitch: 0
OEM_FIXED_FONT:         Terminal (Terminal),                    -9, 12, DPI: 96, charset: 255, pitch: 2
SYSTEM_FONT:            System (System),                        -12, 16, DPI: 96, charset: 204, pitch: 1
SYSTEM_FIXED_FONT:      Fixedsys (Fixedsys),                    -12, 16, DPI: 96, charset: 204, pitch: 2
CaptionFont:            Trebuchet MS (Trebuchet MS),            14, -19, DPI: 96, charset: 1, pitch: 0
SmCaptionFont:          Tahoma (Tahoma),                        9, -12, DPI: 96, charset: 1, pitch: 0
MenuFont:               Tahoma (Tahoma),                        10, -13, DPI: 96, charset: 1, pitch: 0
StatusFont:             Tahoma (Tahoma),                        10, -13, DPI: 96, charset: 1, pitch: 0
MessageFont:            Tahoma (Tahoma),                        10, -13, DPI: 96, charset: 1, pitch: 0

Шрифты в Vista/7

(DPI экрана был 120)

ANSI_FIXED_FONT:        Courier (Courier New),                  -7, 12, DPI: 120, charset: 0, pitch: 2
ANSI_VAR_FONT:          MS Sans Serif (MS Sans Serif),          -7, 12, DPI: 120, charset: 0, pitch: 1
DEVICE_DEFAULT_FONT:    System (System),                        -12, 20, DPI: 120, charset: 204, pitch: 1
DEFAULT_GUI_FONT:       MS Shell Dlg (Microsoft Sans Serif),    8, -13, DPI: 120, charset: 204, pitch: 0
OEM_FIXED_FONT:         Terminal (Terminal),                    -12, 20, DPI: 120, charset: 255, pitch: 2
SYSTEM_FONT:            System (System),                        -12, 20, DPI: 120, charset: 204, pitch: 1
SYSTEM_FIXED_FONT:      Fixedsys (Fixedsys),                    -12, 20, DPI: 120, charset: 204, pitch: 2
CaptionFont:            Segoe UI (Segoe UI),                    9, -15, DPI: 120, charset: 1, pitch: 0
SmCaptionFont:          Segoe UI (Segoe UI),                    9, -15, DPI: 120, charset: 1, pitch: 0
MenuFont:               Segoe UI (Segoe UI),                    9, -15, DPI: 120, charset: 1, pitch: 0
StatusFont:             Segoe UI (Segoe UI),                    9, -15, DPI: 120, charset: 1, pitch: 0
MessageFont:            Segoe UI (Segoe UI),                    9, -15, DPI: 120, charset: 1, pitch: 0

Выводы

Из вышесказанного видно, что подходящим шрифтом для окон является lfMessageFont от SystemParametersInfo, а подходящим шрифтом для моноширинного отображения - ANSI_FIXED_FONT от GetStockObject.

Поскольку Delphi использует намертво зашитые в программу имена шрифтов (MS Sans Serif, Tahoma и MS Shell Dlg 2) - это не всегда самый удачный выбор, если вы хотите "идти в ногу со временем" (*): чтобы ваша программа использовала бы тот же шрифт, что и все остальные программы.

Чтобы исправить это, вы можете добавить в секцию uses такой модуль:

unit UseNewFonts;

interface

uses
  Graphics;

function GUIFont: TFont;
function MonoFont: TFont;

implementation

uses
  Windows,
  SysUtils;

var 
  FGUIFont: TFont;
  FMonoFont: TFont;

function GUIFont: TFont;
begin
  Result := FGUIFont;
end;

function MonoFont: TFont;
begin
  Result := FMonoFont;
end;

procedure InitDefFontData;
var
  Metrics: TNonClientMetrics;
begin
  FGUIFont := TFont.Create;
  FMonoFont := TFont.Create;

  FillChar(Metrics, SizeOf(Metrics), 0);
  Metrics.cbSize := Metrics.SizeOf; // := SizeOf(Metrics); - для старых Delphi
  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, Metrics.cbSize, @Metrics, 0) then
  begin
    FGUIFont.Handle := CreateFontIndirect(Metrics.lfMessageFont);

    DefFontData.Height := FGUIFont.Height;
    DefFontData.Orientation := FGUIFont.Orientation;
    DefFontData.Pitch := FGUIFont.Pitch;
    DefFontData.Style := FGUIFont.Style;
    DefFontData.Charset := FGUIFont.Charset;
    DefFontData.Name := UTF8EncodeToShortString(FGUIFont.Name); // UTF8Encode или AnsiToUTF8 для старых Delphi
    DefFontData.Quality := FGUIFont.Quality; // Только для Delphi XE и выше
  end;

  FMonoFont.Handle := GetStockObject(ANSI_FIXED_FONT);
end;

initialization
  InitDefFontData;

finalization
  FreeAndNil(FMonoFont);
  FreeAndNil(FGUIFont);

end.

Плюс для каждой формы вы должны установить ей ParentFont = True. Вот и всё. Теперь ваша программа будет использовать шрифт для UI, установленный в системе.

А если у вас есть элементы управления, которые нуждаются в моноширинном шрифте, то вместо изменения шрифта на фиксированные в инспекторе объектов в режиме проектирования - лучше не трогайте его (оставив ParentFont = True для этого элемента управления), а напишите в FormCreate присвоение шрифта, например:

Memo1.Font := MonoFont;

(разумеется, у вас должен быть подключен модуль UseNewFonts).

(*) Вообще-то шрифты вроде MS Shell Dlg 2 не являются строго фиксированными (в отличие от, скажем, Tahoma). Вместо MS Shell Dlg 2 в вашу программу будет подставляться шрифт, указанный в экранных настройках пользователя. Поэтому даже если вы установите своим элементам управления фиксированный шрифт MS Shell Dlg 2 - их вид всё ещё может меняться! Поэтому либо вы должны быть готовы к адаптации размеров своих элементов управления, либо ставить действительно конкретный шрифт.