[nnm4evr]

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

[lmikle]

Есть еще такой вариант:

Код:

function LoadResourceFont( const ResourceName, FontName : string ) : boolean;
var
   ResStream : tResourceStream;
   FontsCount : integer;
   hFont : tHandle;
begin
   ResStream := tResourceStream.Create(hInstance, ResourceName, RT_RCDATA);
   hFont := AddFontMemResourceEx(ResStream.Memory, ResStream.Size, nil, @FontsCount);
   result := (hFont <> 0);
   ResStream.Free();
end;

Еще прочитай ответ вот тут: https://stackoverflow.com/questions/...-resource?rq=1

[nnm4evr]

Сообщение от lmikle

Есть еще такой вариант:

Предложенный Вами код работает только на WinXP, но на Win7 не хочет, Label просто исчезает. Я бы все же хотел бы чтобы программа нормально работала на всей линейке Windows, от WinXP и до Win10. Но видимо какого-то универсального способа нет и придется все пихать в инсталлятор, а я хотел распространять прогу ещё и в портабельной версии в zip архиве. Похоже для портабельной версии придется идти сложным путем и писать ещё мини-прогу которая установит в систему шрифт при первом запуске основной программы. Хотелось бы чтобы пользователь не смог стащить шрифт, но не выйдет.

[lmikle]

Я же дал ссылку, там говорится о том, что МС поменяла политику со шрифтами. Была надежда, что из памяти все-таки позволит установить шрифт. Видимо, не судьба.

[nnm4evr]

Я сделал небольшое видео происходящего в Win7 и WinXP, правда для зарубежного форума, но там и так все понятно. Хотя на том зарубежном форуме пишут, что у них все якобы работает.
Ссылка на видео - YouTube
Ссылка на тему на зарубежном форуме (ник у меня там такой же как здесь)

Если получится заставить все это работать, то выложу исходники сюда.

[nnm4evr]

В общем добились мы работы приложения в Win7 и даже Win10. Как и обещал прикрепляю исходники. Проект выгружает шрифт из DLL файла в указанную в коде папку, можно в любую какую захотите. Project1 - сама программа, Project2 - Исходник для DLL, FontRes.rc и FontRes.res файлы для добавления шрифта в ресурсы (легко сделать при помощи BRCC32 из набора любой Delphi) и затем в DLL через Project2.