在Windows 10上使用字体时，为什么GDI +会过多地占用内存？

Question

与Windows 10相比，在Windows 7/8 / 8.1上进行监视时，我的应用程序显示出非常不同且非常烦人的内存占用。我将其归结为字体使用情况：

与其花费50-70 MB来枚举已安装的字体及其属性（就像该应用程序在Windows 7/8 / 8.1上所做的那样），不如花费大约500 MB来完成同一工作，这大约是它的十倍。

在谈到所需的内存时，我总是指进程的虚拟大小。

知道为什么会这样吗？似乎有些缓存在Windows 10上很流行。有什么好的解决方法？目前，我计划将所有GDI +字体处理调用映射到GDI调用，因为这些不会显示这种奇怪的行为。

（我发现Windows 10上的.NET FontFamily内存泄漏，但是没有有用的答案。）

为了缩小范围，我创建了两个示例程序。您可以运行程序并自行比较进程的VirtualSize。

C＃示例仅枚举所有已安装的字体并实例化一种字体，同时适当处理非托管对象：

int i = 0;
foreach (FontFamily fontfamily in FontFamily.Families)
{
    i++;
    try
    {
        Font f = new Font(fontfamily, (float) 8.0, FontStyle.Bold);
        Console.WriteLine("Created Font #{0} {1} ", i, f.Name);

        f.Dispose();
        f = null;
    }
    catch (Exception ex)
    {
        Console.WriteLine("Exception while creating Font {0} {1}", fontfamily.Name, ex.ToString());
    }
    fontfamily.Dispose();
}

Delphi示例更加复杂，使某些.NET内部结构更加明显。此外，您可以使用它进行不同的测试，以更出色的方式测量内存消耗。

program FontTests01;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  Classes,
  Windows,
  System.SysUtils,
  IOUtils,
  WinApi.GDIPAPI,
  WinApi.GDIPOBJ;

const
  cFontlistFilename = 'C:\Temp\fontlist.dat';

type
  TTestCallback = procedure;

function ConsoleWaitForKey: Char;
var
  s: string;
begin
  Readln(s);
  if Length(s) > 0 then
    Result := s[1]
  else
    Result := #0;
end;

procedure TestFontEnumeration(GetFontname: Boolean; GetAvailability: Boolean; FontNamesListFilename: string);
var
  FontCollection: TGPFontCollection;
  FontFamilies: array of TGPFontFamily;
  FontFamily: TGPFontFamily;
  FontName: string;
  i, FontFamiliesRetrieved: Integer;
begin
  if (FontNamesListFilename <> '') and (FileExists(FontNamesListFilename)) then
    DeleteFile(FontNamesListFilename);

  FontCollection := TGPInstalledFontCollection.Create;
  try
    SetLength(FontFamilies, FontCollection.GetFamilyCount);
    ZeroMemory(@FontFamilies[0], SizeOf(TGPFontFamily) * Length(FontFamilies));
    try
      for i := 0 to Length(FontFamilies) - 1 do
        FontFamilies[i] := TGPFontFamily.Create;

      FontCollection.GetFamilies(Length(FontFamilies), FontFamilies, FontFamiliesRetrieved);
      for i := 0 to FontFamiliesRetrieved - 1 do
      begin
        FontFamily := FontFamilies[i];
        if GetFontname then
        begin
          FontFamily.GetFamilyName(FontName);
          Write('Retrieved Font: ' + FontName + ' ');
          if FontNamesListFilename <> '' then
            TFile.AppendAllText(FontNamesListFilename, FontName + #13#10);
        end
        else
          Write(IntToStr(i) + ' ');
        if GetAvailability then
        begin
          if FontFamily.IsAvailable and FontFamily.IsStyleAvailable(FontStyleRegular) then
            Writeln('available ')
          else
            Writeln('NOT available');
        end
        else
          Writeln;
      end;
    finally
      for i := 0 to Length(FontFamilies) - 1 do
        FontFamilies[i].Free;
    end;
  finally
    FontCollection.Free;
  end;
end;

procedure TestFontInstantiation(GetName: Boolean; GetAvailability: Boolean; FontNamesListFilename: string);
var
  List: TStringList;
  FontFamily: TGPFontFamily;
  FontName: string;
  i: Integer;
begin
  List := TStringList.Create;
  try
    List.LoadFromFile(FontNamesListFilename);
    for I := 0 to List.Count - 1 do
    begin
      FontFamily := TGPFontFamily.Create(List[i]);
      try
        if GetName then
        begin
          FontFamily.GetFamilyName(FontName);
          Write('Retrieved Font: ' + FontName + ' ');
        end
        else
          Write(IntToStr(i) + ' ');
        if GetAvailability then
        begin
          if FontFamily.IsAvailable and FontFamily.IsStyleAvailable(FontStyleRegular) then
            Writeln('available ')
          else
            Writeln('NOT available');
        end
        else
          Writeln;
      finally
        FontFamily.Free;
      end;
    end;
  finally
    List.Free;
  end;
end;

function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data: Pointer): Integer; stdcall;
begin
  Writeln(LogFont.lfFaceName);
  Result := 1;
end;

procedure EnumerateFontsWithGDI;
var
  DC: HDC;
  LFont: TLogFont;
begin
  DC := GetDC(0);
  try
    FillChar(LFont, sizeof(LFont), 0);
    LFont.lfCharset := DEFAULT_CHARSET;
    EnumFontFamiliesEx(DC, LFont, @EnumFontsProc, 0, 0);
  finally
    ReleaseDC(0, DC);
  end;
end;

procedure TestFontEnumeration_GetFontNames_Only;
begin
  TestFontEnumeration(True, False, cFontlistFilename);
end;

procedure TestFontEnumeration_GetFontAvailability_Only;
begin
  TestFontEnumeration(False, True, '');
end;

procedure TestFontEnumeration_GetFontName_GetFontAvailability_Combined;
begin
  TestFontEnumeration(True, True, '');
end;

procedure TestFontNames_FromFile_CreateNamedGPFontFamilies_Only;
begin
  TestFontInstantiation(False, False, cFontlistFilename);
end;

procedure TestFontNames_FromFile_RetrieveFontNamesAgain;
begin
  TestFontInstantiation(True, False, cFontlistFilename);
end;

procedure TestFontNames_FromFile_GetFontAvailable;
begin
  TestFontInstantiation(False, True, cFontlistFilename);
end;

procedure TestFontNames_FromFile_RetrieveFontNames_GetFontAvailable_Combined;
begin
  TestFontInstantiation(True, True, cFontlistFilename);
end;

procedure Test_EnumerateFontsWithGDI;
begin
  EnumerateFontsWithGDI;
end;

procedure PerformTest(Caption: string; Callback: TTestCallback);
var
  Key: Char;
begin
  Writeln('Before Test ' + Caption + '. Hit "s" to skip, enter to continue.');
  Key := ConsoleWaitForKey;
  if AnsiLowerCase(Key) <> 's' then
  begin
    Callback;
    Writeln('Test ' +  Caption + ' finished. Hit a enter.');
    ConsoleWaitForKey;
  end
  else
    Writeln('Test ' +  Caption + ' skipped.');
  Writeln;
end;

begin
  try
    PerformTest('TestFontEnumeration_GetFontNames_Only', TestFontEnumeration_GetFontNames_Only);
    PerformTest('TestFontEnumeration_GetFontAvailability_Only', TestFontEnumeration_GetFontAvailability_Only);
    PerformTest('TestFontEnumeration_GetFontName_GetFontAvailability_Combined', TestFontEnumeration_GetFontName_GetFontAvailability_Combined);
    PerformTest('TestFontNames_FromFile_CreateNamedGPFontFamilies_Only', TestFontNames_FromFile_CreateNamedGPFontFamilies_Only);
    PerformTest('TestFontNames_FromFile_RetrieveFontNamesAgain', TestFontNames_FromFile_RetrieveFontNamesAgain);
    PerformTest('TestFontNames_FromFile_GetFontAvailable', TestFontNames_FromFile_GetFontAvailable);
    PerformTest('TestFontNames_FromFile_RetrieveFontNames_GetFontAvailable_Combined', TestFontNames_FromFile_RetrieveFontNames_GetFontAvailable_Combined);
    PerformTest('Test_EnumerateFontsWithGDI', Test_EnumerateFontsWithGDI);
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Writeln('Finished.');
  ConsoleWaitForKey;
end.