delphi - 如何临时加载字体？

Question

我需要在我的程序中临时加载一些字体。最好来自 dll 资源文件。

Answer 1

这里有一个 Delphi 版本：

procedure LoadFontFromDll(const DllName, FontName: PWideChar);
var
  DllHandle: HMODULE;
  ResHandle: HRSRC;
  ResSize, NbFontAdded: Cardinal;
  ResAddr: HGLOBAL;
begin
  DllHandle := LoadLibrary(DllName);
  if DllHandle = 0 then
    RaiseLastOSError;
  ResHandle := FindResource(DllHandle, FontName, RT_FONT);
  if ResHandle = 0 then
    RaiseLastOSError;
  ResAddr := LoadResource(DllHandle, ResHandle);
  if ResAddr = 0 then
    RaiseLastOSError;
  ResSize := SizeOfResource(DllHandle, ResHandle);
  if ResSize = 0 then
    RaiseLastOSError;
  if 0 = AddFontMemResourceEx(Pointer(ResAddr), ResSize, nil, @NbFontAdded) then
    RaiseLastOSError;
end;

像这样使用：

var
  FontName: PChar;
  FontHandle: THandle;
...
  FontName := 'DEJAVUSANS';
  LoadFontFromDll('Project1.dll' , FontName);
  FontHandle := CreateFont(0, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET,
    OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH,
    FontName);
  if FontHandle = 0 then
    RaiseLastOSError;

Answer 2

我用谷歌找到了这个。我已经剪切并粘贴了下面的相关代码。

您需要将字体添加到资源文件中：

34 FONT "myfont.ttf"

下面的 C 代码将从 DLL 资源加载字体，并在您使用完毕后从内存中释放它。

双字计数；
HMODULE 模块 = LoadLibrary("mylib.dll");
HRSRC 资源 = FindResource(Module,MAKEINTRESOURCE(34),RT_FONT);
DWORD 长度 = SizeofResource（模块，资源）；
HGLOBAL 地址 = LoadResource(Module,Resource);
HANDLE 句柄 = AddFontMemResourceEx(Address,Length,0,&Count);

/* 在这里使用字体... */

RemoveFontMemResourceEx（句柄）；
免费图书馆（模块）；

Answer 3

这里有一些代码可以从可执行文件中加载/使字体可用（即，字体作为资源嵌入，而不是您通常必须安装到 Windows 中的东西）。

请注意，在您的程序摆脱它之前，任何应用程序都可以使用该字体。我不知道你会发现它有多大用处，但我已经用过几次了。我从未将字体放入 dll 中（我更喜欢这种“嵌入到 exe 中”的方法），但不要想象它会改变太多。

过程 TForm1.FormCreate(Sender: TObject);
变量
    资源流：TResourceStream；
    sFileName：字符串；
开始
    sFileName:=ExtractFilePath(Application.ExeName)+'SWISFONT.TTF';

    ResStream：=无；
    尝试
        ResStream:=TResourceStream.Create(hInstance, 'Swisfont', RT_RCDATA);
        尝试
            ResStream.SaveToFile(sFileName);
        除了
            在 E:EFCreateError 上做 ShowMessage(E.Message);
        结尾;
    最后
        ResStream.免费；
    结尾;

    AddFontResource(PChar(sFileName));
    SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
结尾;


过程 TForm1.FormDestroy(Sender: TObject);
变量
    s文件：字符串；
开始
    sFile:=ExtractFilePath(Application.ExeName)+'SWISFONT.TTF';
    如果 FileExists(sFile) 然后
    开始
        RemoveFontResource(PChar(sFile));
        SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
        删除文件（sFile）；
    结尾;
结尾;