delphi4arab منتديات دلفي للعرب

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

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

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

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

سلام

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.

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

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

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

كود :
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

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

(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

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

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

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

كود :
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;

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

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

khedimaadl

الفجر الابيض

khedimaadl

Ndagor

khedimaadl

Ndagor

khedimaadl

Ndagor

khedimaadl