В настоящее время я использую функцию SystemParametersInfo для извлечения SPI_GETICONTITLELOGFONT. Согласно документации MSDN это http://msdn.microsoft.com/en-us/library/ms724947(VS.85).aspx
"Получает информацию о логическом шрифте для текущего шрифта заголовка значка"
Но это всегда извлекает "Segoe UI", даже когда я меняю свой шрифт на "VivlaidD". Я нахожусь на машине Windows 7. Является ли это, что эта функция только восстанавливает системный дефолт? Или что-то не так с "SystemParametersInfo"?
Вот мой код для извлечения шрифта:
procedure GetUserFontPreference(out FaceName: string; out PixelHeight: Integer);
var
lf: LOGFONT;
begin
ZeroMemory(@lf, SizeOf(lf));
if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(lf), @lf, 0) then
begin
FaceName := PChar(Addr(lf.lfFaceName[0]));
PixelHeight := lf.lfHeight;
end
else
begin
{
If we can't get it, then assume the same non-user preferences that
everyone else does.
}
FaceName := 'MS Shell Dlg 2';
PixelHeight := 8;
end;
end;
Проблема заключается в не с вашим кодом, как вы можете видеть со следующим консольным приложением D2010, изменением и извлечением шрифта и хорошей работой на Win7 x64:
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils, Windows;
procedure GetUserFontPreference(out FaceName: string; out PixelHeight: Integer);
var
lf: LOGFONT;
begin
ZeroMemory(@lf, SizeOf(lf));
if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(lf), @lf, 0) then
begin
FaceName := lf.lfFaceName; // simpler than PChar(Addr(lf.lfFaceName[0]));
PixelHeight := lf.lfHeight;
end
else
begin
{
If we can t get it, then assume the same non-user preferences that
everyone else does.
}
FaceName := 'MS Shell Dlg 2';
PixelHeight := 8;
end;
end;
procedure SetUserFontPreference(const AFaceName: string; const APixelHeight: Integer);
var
lf: LOGFONT;
begin
ZeroMemory(@lf, SizeOf(lf));
Move(AFaceName[1], lf.lfFaceName, Length(AFaceName)*SizeOf(Char));
lf.lfHeight := APixelHeight;
SystemParametersInfo(SPI_SETICONTITLELOGFONT, SizeOf(lf), @lf, 0);
end;
procedure Test;
var
FontName, NewFontName, OldFontName: string;
FontHeight: Integer;
begin
GetUserFontPreference(OldFontName, FontHeight);
Writeln('Current (Old) Font is ', OldFontName);
Readln;
NewFontName := 'Rage Italic'; //'Segoe UI';//'Rage Italic';
SetUserFontPreference(NewFontName, FontHeight);
GetUserFontPreference(FontName, FontHeight);
Assert(FontName=NewFontName);
Writeln('Current (New) Font is ', FontName);
Readln;
SetUserFontPreference(OldFontName, FontHeight);
GetUserFontPreference(FontName, FontHeight);
Assert(FontName=OldFontName);
Writeln('Current Font is back to (Old) ', FontName);
Readln;
end;
begin
try
Test;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Возможно, вы изменили неправильный шрифт в меню персонализации? Если я изменил шрифт Icon из Segoe UI в Verdana, следующий код работает правильно:
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils, Windows;
var
LogFont: TLogFont;
begin
try
if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(LogFont),
@LogFont, 0) then
Writeln('Current Font is ', LogFont.lfFaceName)
else
Writeln('Error #', GetLastError);
Readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.