تنصيب الخطوط برمجيا على الجهاز

[khedimaadl]

السلام عليكم ورحمة الله وبركاته
كيف أستطيع أن أنصب الخطوط برمجيا على مجلد الخطوط في الوندوز
وتبقى تلك الخطوط في الوندوز لاستعمالها من طرف برامج أخرى
وشكرا

[الفجر الابيض]

يمكنك استخدام الدالة 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;

[khedimaadl]

يمكنك استخدام الدالة 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;

بارك الله فيك أخي العزيز
جربت الكود الذي أخبرتني عنه، لكن الدلفي اعترض على الكلمة ( WM_FONTCHANGE ) ويعطيني خطأ عندها
قلت لي :  يرجى ملاحظة أن هذه العملية تتطلب صلاحيات إدارية 
كيف أتحصل على هذه الصلاحية برمجيا من فضلك

[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.

[khedimaadl]

سلام

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.

السلام عليكم 
شكرا جزيلا أخي العزيز، وبارك الله فيك 
الكود عمل بشكل جيد جدا
لكن عندما أردت أن أثبت أكثر من خط مثلا 3 خطوط ظهرت لي رسالة الصلاحية 3 مرات
هل يوجد طريقة لظهور رسالة الصلاحية مرة واحدة وبها يتم تثبيت الخطوط الثلاثة دفعة واحدة ؟

[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

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

[khedimaadl]

لتثبيت الخطوط الثلاثة دفعة واحدةز

كود :

        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

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

هذا الكود يعمل حتى بعد إعادة تشغيل الحاسب يعني كود ممتاز، لكن الخطوط الثلاثة بهذه الطريقة تعطينا ثلاث رسائل من الوندوز للصلاحية ، وأنا لا أريد هذا بل أريد أن تظهر رسالة واحدة فقط تنوب عن البقية

[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;

[khedimaadl]

جرب هذا الكود..
[

كود :

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;

بارك الله فيك أخي العزيز
وجزاك الله كل خير، لقد نجح الأمر
أشكرك شكرا جزيلا على اهتمامك، وحرصك على مساعدتي
شكرا شكرا