كيف يمكنني تحميل الخط بشكل مؤقت؟
سؤال
أحتاج إلى تحميل بعض الخطوط مؤقتًا في برنامجي.ويفضل أن يكون من ملف الموارد dll.
المحلول
وهنا نسخة دلفي:
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;
نصائح أخرى
وجدت هذا مع جوجل.لقد قمت بقص ولصق الكود ذي الصلة أدناه.
تحتاج إلى إضافة الخط إلى ملف الموارد الخاص بك:
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);
إليك بعض التعليمات البرمجية التي ستقوم بتحميل/إتاحة الخط من داخل الملف القابل للتنفيذ (على سبيل المثال، تم تضمين الخط كمورد، بدلاً من شيء كان عليك تثبيته في 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;
لا تنتمي إلى StackOverflow