كيف يمكنني تحميل الخط بشكل مؤقت؟

Question

أحتاج إلى تحميل بعض الخطوط مؤقتًا في برنامجي.ويفضل أن يكون من ملف الموارد dll.

Answer 1

وهنا نسخة دلفي:

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 وتحريره من الذاكرة عند الانتهاء من استخدامه.

DWORD   Count;
HMODULE Module   = LoadLibrary("mylib.dll");
HRSRC   Resource = FindResource(Module,MAKEINTRESOURCE(34),RT_FONT);
DWORD   Length   = SizeofResource(Module,Resource);
HGLOBAL Address  = LoadResource(Module,Resource);
HANDLE  Handle   = AddFontMemResourceEx(Address,Length,0,&Count);

/* Use the font here... */

RemoveFontMemResourceEx(Handle);
FreeLibrary(Module);

Answer 3

إليك بعض التعليمات البرمجية التي ستقوم بتحميل/إتاحة الخط من داخل الملف القابل للتنفيذ (على سبيل المثال، تم تضمين الخط كمورد، بدلاً من شيء كان عليك تثبيته في Windows بشكل عام).

لاحظ أن الخط متاح ل أي التطبيق حتى يتخلص برنامجك منه.لا أعرف مدى فائدة هذا، ولكني استخدمته عدة مرات.لم أضع الخط مطلقًا في ملف dll (أفضل أسلوب "التضمين في ملف exe") ولكن لا أتخيل أنه يغير الأشياء كثيرًا.

procedure TForm1.FormCreate(Sender: TObject);
var
    ResStream : TResourceStream;
    sFileName : string;
begin
    sFileName:=ExtractFilePath(Application.ExeName)+'SWISFONT.TTF';

    ResStream:=nil;
    try
        ResStream:=TResourceStream.Create(hInstance, 'Swisfont', RT_RCDATA);
        try
            ResStream.SaveToFile(sFileName);
        except
            on E:EFCreateError Do ShowMessage(E.Message);
        end;
    finally
        ResStream.Free;
    end;

    AddFontResource(PChar(sFileName));
    SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;


procedure TForm1.FormDestroy(Sender: TObject);
var
    sFile:string;
begin
    sFile:=ExtractFilePath(Application.ExeName)+'SWISFONT.TTF';
    if FileExists(sFile) then
    begin
        RemoveFontResource(PChar(sFile));
        SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
        DeleteFile(sFile);
    end;
end;