Форум по Delphi программированию

Delphi Sources



Вернуться   Форум по Delphi программированию > Все о Delphi > Программа и интерфейс
Ник
Пароль
Регистрация <<         Правила форума         >> FAQ Пользователи Календарь Поиск Сообщения за сегодня Все разделы прочитаны

Ответ
 
Опции темы Поиск в этой теме Опции просмотра
  #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 просмотров)

Последний раз редактировалось nnm4evr, 10.07.2017 в 20:37.
Ответить с цитированием
  #2  
Старый 10.07.2017, 21:56
lmikle lmikle вне форума
Модератор
 
Регистрация: 17.04.2008
Сообщения: 8,051
Версия Delphi: 7, XE3, 10.2
Репутация: 49089
По умолчанию

Есть еще такой вариант:
Код:
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
Ответить с цитированием
  #3  
Старый 11.07.2017, 04:53
nnm4evr nnm4evr вне форума
Прохожий
 
Регистрация: 10.07.2017
Сообщения: 7
Версия Delphi: Delphi 7
Репутация: 10
По умолчанию

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

Последний раз редактировалось nnm4evr, 11.07.2017 в 04:55.
Ответить с цитированием
  #4  
Старый 11.07.2017, 05:18
lmikle lmikle вне форума
Модератор
 
Регистрация: 17.04.2008
Сообщения: 8,051
Версия Delphi: 7, XE3, 10.2
Репутация: 49089
По умолчанию

Я же дал ссылку, там говорится о том, что МС поменяла политику со шрифтами. Была надежда, что из памяти все-таки позволит установить шрифт. Видимо, не судьба.
Ответить с цитированием
  #5  
Старый 11.07.2017, 11:32
nnm4evr nnm4evr вне форума
Прохожий
 
Регистрация: 10.07.2017
Сообщения: 7
Версия Delphi: Delphi 7
Репутация: 10
По умолчанию

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

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

Последний раз редактировалось nnm4evr, 12.07.2017 в 07:28.
Ответить с цитированием
  #6  
Старый 13.07.2017, 07:09
nnm4evr nnm4evr вне форума
Прохожий
 
Регистрация: 10.07.2017
Сообщения: 7
Версия Delphi: Delphi 7
Репутация: 10
По умолчанию

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


Delphi Sources

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск
Опции просмотра

Ваши права в разделе
Вы не можете создавать темы
Вы не можете отвечать на сообщения
Вы не можете прикреплять файлы
Вы не можете редактировать сообщения

BB-коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.
Быстрый переход


Часовой пояс GMT +3, время: 02:28.


 

Сайт

Форум

FAQ

RSS лента

Прочее

 

Copyright © Форум "Delphi Sources" by BrokenByte Software, 2004-2023

ВКонтакте   Facebook   Twitter