{

Based on code from http://www.gunsmoker.ru/2010/11/windows-xp-windows-vista7.html

}
unit NewFonts;

interface

uses
  Graphics;

procedure ApplyNewFonts();

function GUIFont: TFont;
function MonoFont: TFont;

implementation

uses
  Windows, SysUtils, Forms;

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;

procedure ApplyNewFonts();
var
  i: integer;
begin
    for i := 0 to Application.ComponentCount - 1 do
      if Application.Components[i] is TForm then
        with (Application.Components[i] as TForm) do
          Font := GUIFont
            ;
end;

initialization
  InitDefFontData;

finalization
  FreeAndNil(FMonoFont);
  FreeAndNil(FGUIFont);

end.
