6 ноября 2010 г.

Шрифты в 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 - их вид всё ещё может меняться! Поэтому либо вы должны быть готовы к адаптации размеров своих элементов управления, либо ставить действительно конкретный шрифт.

10 комментариев :

  1. Давно нечто подобное использую в своих программах (в OnCreate формы устанавливаю шрифт из параметров системы).

    Маленькая ремарка: если пользователь вдруг сменил шрифт в системе (ну например переключил тему оформления с Aero на классическую), то ОС отсылает всем окнам верхнего уровня сообщение WM_SETTINGCHANGE, у которого WParam = SPI_SETNONCLIENTMETRICS.

    Если Вы хотите, чтобы приложение реагировало на такие изменения, то это можно сделать в обработчике Application.OnSettingChange. Здесь надо анализировать параметр Flag, и если он равен SPI_SETNONCLIENTMETRICS, то (самое простое что можно сделать) перебирать все формы Screen и устанавливать в них шрифт.

    ОтветитьУдалить
  2. мм.. не очень внимательно просмотрел код UseNewFonts. В этом варианте достаточно в Application.OnSettingChange заново инициализировать DefFontData, нежели перебирать все формы приложения... но суть не в этом, суть в том, чтобы обрабатывать WM_SETTINGCHANGE.

    ОтветитьУдалить
  3. мысли вслух: для одинаковых DPI у шрифта Segoe UI (Vista/7) ширина символов больше, чем ширина символов у шрифта Tahoma (XP). Это приводит к тому, что текст в некоторых метках (TLabel) в Vista/7 уходит за границу окна/панели/другого компонента.
    ..подумываю о том, что надо масштабировать окна по горизонтали..

    ОтветитьУдалить
  4. Просто интересно - это так и задумано, что текст (код) не копируется нормальным(нет sLineBreak) или я чего-то не вижу? :-)

    ОтветитьУдалить
  5. Нет, должно копироваться нормально. С переносами строк и без их нумерации.

    ОтветитьУдалить
  6. Что то или я или Delphi 7 не понимаем "AFont.Quality"

    ОтветитьУдалить
  7. Я не имею желания адаптировать этот код под каждую версию Delphi. Я полагаю, что вы достаточно умны, чтобы сделать это самостоятельно.

    ОтветитьУдалить
  8. Подскажи а можно так линух под xp настроить - дело магарычовое.

    ОтветитьУдалить
  9. Lazarus и Delphi выдают разный размер шрифта 12 и 9 соответственно. Всё сводится к вызову одной функции из одного места и там и там.
    function CreateFontIndirect(var _para1:LOGFONT):HFONT; external 'gdi32' name 'CreateFontIndirectA'; // Lazarus
    function CreateFontIndirect; external gdi32 name 'CreateFontIndirectA'; // Delphi 2006

    ОтветитьУдалить
    Ответы
    1. Значения шрифтов и DPI, которые получает программа, зависят от слоя обратной совместимости ОС. В частности, Windows может посчитать, что старое приложение не умеет работать с высоким DPI и поэтому подсунет ему DPI 96 и шрифт размера 8-9. Разные версии Windows имеют различные алгоритмы для такого масштабирования. Правила отличаются в XP и ниже, от Vista до 10, от 10 и выше.

      Приложение может обозначить, что оно в курсе про то, что бывают иные DPI и размеры шрифтов.

      Удалить

Можно использовать некоторые HTML-теги, например:

<b>Жирный</b>
<i>Курсив</i>
<a href="http://www.example.com/">Ссылка</a>

Вам необязательно регистрироваться для комментирования - для этого просто выберите из списка "Анонимный" (для анонимного комментария) или "Имя/URL" (для указания вашего имени и (опционально) ссылки на сайт). Все прочие варианты потребуют от вас входа в вашу учётку (поддерживается OpenID).

Пожалуйста, по возможности используйте "Имя/URL" вместо "Анонимный". URL можно просто не указывать.

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