|
|
Регистрация | << Правила форума >> | FAQ | Пользователи | Календарь | Поиск | Сообщения за сегодня | Все разделы прочитаны |
|
Опции темы | Поиск в этой теме | Опции просмотра |
#1
|
|||
|
|||
Установка своего шрифта на время работы программы
Здравствуйте! Существует ли способ временно (на время работы программы) установить свой шрифт в систему и использовать его в программе?
Я уже перепробовал кучу способов и не один пока не работает, во всяком случае на 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) Способ 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. Последний раз редактировалось nnm4evr, 10.07.2017 в 20:37. |
#2
|
|||
|
|||
Есть еще такой вариант:
Код:
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
|
|||
|
|||
Цитата:
Последний раз редактировалось nnm4evr, 11.07.2017 в 04:55. |
#4
|
|||
|
|||
Я же дал ссылку, там говорится о том, что МС поменяла политику со шрифтами. Была надежда, что из памяти все-таки позволит установить шрифт. Видимо, не судьба.
|
#5
|
|||
|
|||
Я сделал небольшое видео происходящего в Win7 и WinXP, правда для зарубежного форума, но там и так все понятно. Хотя на том зарубежном форуме пишут, что у них все якобы работает.
Ссылка на видео - YouTube Ссылка на тему на зарубежном форуме (ник у меня там такой же как здесь) Если получится заставить все это работать, то выложу исходники сюда. Последний раз редактировалось nnm4evr, 12.07.2017 в 07:28. |
#6
|
|||
|
|||
В общем добились мы работы приложения в Win7 и даже Win10. Как и обещал прикрепляю исходники. Проект выгружает шрифт из DLL файла в указанную в коде папку, можно в любую какую захотите. Project1 - сама программа, Project2 - Исходник для DLL, FontRes.rc и FontRes.res файлы для добавления шрифта в ресурсы (легко сделать при помощи BRCC32 из набора любой Delphi) и затем в DLL через Project2.
|