Показать сообщение отдельно
  #1  
Старый 10.07.2017, 20:35
nnm4evr nnm4evr вне форума
Прохожий
 
Регистрация: 10.07.2017
Сообщения: 7
Версия Delphi: Delphi 7
Репутация: 10
По умолчанию Установка своего шрифта на время работы программы

Здравствуйте! Существует ли способ временно (на время работы программы) установить свой шрифт в систему и использовать его в программе?
Я уже перепробовал кучу способов и не один пока не работает, во всяком случае на 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.
Вложения
Тип файла: zip TempRegFontDLL.zip (97.9 Кбайт, 3 просмотров)
Ответить с цитированием