Здравствуйте! Существует ли способ временно (на время работы программы) установить свой шрифт в систему и использовать его в программе?
Я уже перепробовал кучу способов и не один пока не работает, во всяком случае на Win 7.
Необходимо чтобы способ работал не только в Win XP, но и в Win 7 - 8 - 8,1 - 10.
Я составил список способов которые я попробовал, а так же прикладываю исходники тестовой программки.
В прикрепленном файле Project1.dpr это программа, а Project2.dpr это DLL с шрифтом.
Работаю исключительно в Delphi 7!
Способ 1 (Самый распространенный, но походу не работающий в Win 7 и выше) взято на форумах и сайтах, что выдал гугл:
Код:
AddFontResource('SomeFont.ttf');
RemoveFontResource('SomeFont.ttf');
а так же
Код:
AddFontResourceEx('somefont.ttf',FR_PRIVATE,0);
RemoveFontResourceEx('somefont.ttf',FR_PRIVATE,0);
Если же к выше указанному способу добавить ещё
Код:
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
то программа просто виснет и даже окно программы не появляется, скорее всего эта функция не работает в Win 7 +.
Способ 2 (Может и рабочий, но мне не подходит, т.к. шрифт извлекается из DLL файла и далее уже устанавливается в системе, а тут установка шрифта происходит до Application.Initialize; ) взято
тут:
Код:
const
CKey = '\Software\Microsoft\Windows NT\CurrentVersion\Fonts';
CFontFileName = 'spherelive.ttf';
CFontName = 'spherelive (TrueType)';
procedure ExecuteWait(const sProgramm: string; const sParams: string = ''; fHide: Boolean = false);
var
ShExecInfo: TShellExecuteInfo;
begin
FillChar(ShExecInfo, sizeof(ShExecInfo), 0);
with ShExecInfo do
begin
cbSize := sizeof(ShExecInfo);
fMask := SEE_MASK_NOCLOSEPROCESS;
lpFile := PChar(sProgramm);
lpParameters := PChar(sParams);
lpVerb := 'open';
if (not fHide) then
nShow := SW_SHOW
else
nShow := SW_HIDE
end;
try
if (ShellExecuteEx(@ShExecInfo) and (ShExecInfo.hProcess <> 0)) then
try
WaitForSingleObject(ShExecInfo.hProcess, INFINITE)
finally
CloseHandle(ShExecInfo.hProcess);
end;
except
On E : Exception do
ShowMessage('font install Exception: ' + E.Message);
end;
end;
if not IsFontRegistered(TPath.Combine(ExtractFilePath(ParamStr(0)), CFontFileName), CFontName) then
if FileExists(TPath.Combine(ExtractFilePath(ParamStr(0)), 'MyPrg.exe')) then
ExecuteWait(TPath.Combine(ExtractFilePath(ParamStr(0)), 'MyPrg.exe'));
Application.Initialize;
Способ 3 (Найден на зарубежных форумах и тоже не работает) взято
тут:
Код:
Unit Unit1;
{$mode objfpc}{$H+}
Interface
USES
Windows, Classes, SysUtils, Forms, Controls;
TYPE
TForm1 = Class(TForm)
Procedure FormCreate (Sender: TObject);
Procedure FormClose (Sender: TObject; Var CloseAction: TCloseAction);
End;
CONST
MM_MAX_NUMAXES = 16;
FR_PRIVATE = $10;
FR_NOT_ENUM = $20;
TYPE
PDesignVector = ^TDesignVector;
TDesignVector = Packed Record
dvReserved: DWORD;
dvNumAxes : DWORD;
dvValues : Array[0..MM_MAX_NUMAXES-1] Of LongInt;
End;
VAR
Form1: TForm1;
Function AddFontResourceEx (Dir : PAnsiChar;
Flag: Cardinal;
PDV : PDesignVector): Int64; StdCall;
External 'GDI32.dll' Name 'AddFontResourceExA';
Function RemoveFontResourceEx (Dir : PAnsiChar;
Flag: Cardinal;
PDV : PDesignVector): Int64; StdCall;
External 'GDI32.dll' Name 'RemoveFontResourceExA';
Implementation
{$R *.lfm}
Procedure LoadFonts;
Var
AppPath: String;
Begin
AppPath:= ExtractFilePath(Application.ExeName);
If FileExists(AppPath+'FONTS\MONO.ttf')
Then
If AddFontResourceEx(PAnsiChar(AppPath+'FONTS\MONO.ttf'), FR_Private, Nil) <> 0
Then SendMessage(Form1.Handle, WM_FONTCHANGE, 0, 0);
End;
Procedure RemoveFonts;
Var
AppPath: String;
Begin
AppPath:= ExtractFilePath(Application.ExeName);
If FileExists(AppPath+'FONTS\MONO.ttf')
Then
If RemoveFontResourceEx(PAnsiChar(AppPath+'FONTS\MONO.ttf'), FR_Private, Nil) <> 0
Then SendMessage(Form1.Handle, WM_FONTCHANGE, 0, 0);
End;
Procedure TForm1.FormCreate(Sender: TObject);
Begin
LoadFonts;
End;
Procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
Begin
RemoveFonts;
End;
End.