(07-11-2025, 12:04 PM)الفجر الابيض كتب : يمكنك استخدام الدالة AddFontResource لإضافة الخط إلى مجلد الخطوط في الويندوز. بعد ذلك، يجب عليك إعلام الويندوز بأن هناك تغيير قد حدث في الخطوط باستخدام الدالة SendMessage.
هذا مثال على كيفية القيام بذلك في دلفي:

كود :

uses   Windows; procedure InstallFont(FontFilePath: string); var   FontPath: array[0..MAX_PATH] of Char; begin   if FileExists(FontFilePath) then   begin     StrPCopy(FontPath, FontFilePath);     if AddFontResource(FontPath) <> 0 then     begin       SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);       // نسخ الخط إلى مجلد الخطوط في الويندوز       CopyFile(PChar(FontFilePath), PChar(ExtractFilePath(GetWindowsDir) + 'Fonts\' + ExtractFileName(FontFilePath)), False);     end;   end; end;

يمكنك استدعاء هذه الدالة بتمرير مسار ملف الخط الذي تريد تثبيته: 

كود :

procedure TForm1.Button1Click(Sender: TObject); begin   InstallFont('C:\Path\To\Your\Font.ttf'); end;

يرجى ملاحظة أن هذه العملية تتطلب صلاحيات إدارية في الويندوز. إذا كنت تقوم بتشغيل البرنامج تحت حساب عادي، قد تظهر رسالة خطأ أو لا يتم تثبيت الخط.
أيضا، يجب عليك إضافة ShellAPI إلى uses إذا كنت تستخدم CopyFile:

كود :

uses   Windows, ShellAPI;

إقتباس :قلت لي :  يرجى ملاحظة أن هذه العملية تتطلب صلاحيات إدارية 
كيف أتحصل على هذه الصلاحية برمجيا من فضلك

(08-11-2025, 07:27 PM)Ndagor كتب : سلام

WM_FONTCHANGE ليست مهمة عندما تقوم الوندوز نتثبت الخطوط فمي ستقوم بذلك لاعلام جميع التطبيقات بالخطوط الجديدة ...WM_FONTCHANGE  موجودة في الوحدة Messages هي مهمة للخطوط المؤقتة .

إقتباس :قلت لي :  يرجى ملاحظة أن هذه العملية تتطلب صلاحيات إدارية 
كيف أتحصل على هذه الصلاحية برمجيا من فضلك

انظر في المثال التاليز
قم بو ضع زر لتثبيت الخطوط و قم بربطه بالكود التالي

كود :

implementation uses ShellApi; {$R *.dfm} procedure TForm1.Button2Click(Sender: TObject); begin   ShellExecute(handle,    PChar('runas'),    PChar(ParamStr(0)),    PChar('InstallFonts'),    nil,    SW_HIDE); end;

ثم قم بتعديل ملق المشروع   dpr على هذا النحو:

كود :

program Project1; uses   Forms, Dialogs, ShlObj, ComObj, ActiveX,   Unit1 in 'Unit1.pas' {Form1}; {$R *.res} var   Shell: OleVariant; begin   if Paramstr(1)= 'InstallFonts'then   begin     try         ActiveX.CoInitialize(nil);         Shell := CreateoleObject('Shell.Application');         Shell.NameSpace(CSIDL_FONTS).CopyHere('C:\Users\Ahm\Downloads\Myfont.ttf');      except      end;   end else   begin       Application.Initialize;       Application.CreateForm(TForm1, Form1);       Application.Run;   end; end.

(11-11-2025, 04:43 PM)Ndagor كتب : لتثبيت الخطوط الثلاثة دفعة واحدةز

كود :

        Shell := CreateoleObject('Shell.Application');         Shell.NameSpace(CSIDL_FONTS).CopyHere('C:\Users\Ahm\Downloads\Myfont1.ttf'); Shell.NameSpace(CSIDL_FONTS).CopyHere('C:\Users\Ahm\Downloads\Myfont2.ttf'); Shell.NameSpace(CSIDL_FONTS).CopyHere('C:\Users\Ahm\Downloads\Myfont3.ttf');

المشكلة انه لا يكفي نقل الخطوط الي مجلد C:\Windows\Fonts بل يجب جردها في Registry و لهذا تم اختيار Shell.Application

طبعا لا تنسى تجربة كود المقترح من الفجر الابيض و لكن لا ادي ان كان يعمل بصفة دائمة او فقط الى اعادة تشغيل الحاسب

(12-11-2025, 08:10 PM)Ndagor كتب : جرب هذا الكود..
[

كود :

uses ActiveX, Comobj, ShlObj; {$R *.dfm} function SHCreateFileDataObject(pidlFolder: PItemIDList; cidl: UINT;   apidl: PItemIdList; const pdtInner: IDataObject;   var ppv: IDataObject): HResult; stdcall;  external 'shell32.dll' index 740; procedure FontInstall; const   G: TGUID = '{1a184871-359e-4f67-aad9-5b9905d62232}'; var apidl: array[0..2] of Pointer; DataObject: IDataObject; P: pointer; Menu: IContextMenu; wCmd: TCMInvokeCommandInfo; IExt: IShellExtInit; begin   CoInitialize(nil);   apidl[0] := ILCreateFromPath('C:\Users\Ah\Font1.ttf');   apidl[1] := ILCreateFromPath('C:\Users\Ah\Font2.ttf');   apidl[2] := ILCreateFromPath('C:\Users\Ah\Font3.ttf');   p := nil;   SHCreateFileDataObject(@p, 3, @apidl[0], nil,DataObject);   IExt := CreateComObject(G) as IShellExtInit;   IExt.Initialize(nil, DataObject, 0);   Menu := IExt as IContextMenu;   fillchar(wCmd, Sizeof(wCmd),0);   wCmd.cbSize := Sizeof(wCmd);   wCmd.lpVerb := pAnsichar(Ansistring('Install'));   menu.InvokeCommand(wCmd);   // must free apidl end;