تست وجود فونت در دلفی

آیا راهی می توانید به من بدهید که در هنگام اجرای برنامه وجود یک فونت در سیستم
کاربر چک شود و در صورت نبودن آن را به آن سیستم کپی کند. :(

برای اینکه ببینی فونت روی سیستم register شده یانه میتونی از کد زیر استفاده کنی:

procedure TForm1.Button1Click(Sender: TObject);

var

r:tregistry;

b:boolean;

v:tregdatainfo;

begin

  R := TRegistry.Create(KEY_READ);

  try

    R.RootKey := HKEY_LOCAL_MACHINE;

    R.OpenKey('SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts', False);

    b:=r.GetDataInfo('name of font',v);

  finally

    R.Free;

  end;

end;

name of font اسم فونت مورد نظره.متغیر b بر اساس اینکه true باشه یا false اون چیزی که میخوای نشون میده
این کد رو توی xp نوشتم و نمیدونم روی 98 درسته یا نه :oops:

برای چک وجود فونت از یک کلاس کمکی استفاده میکنیم.

این کدها را به بخش Interface یونیت موردنظر اضافه کنید:

type

  TFONTType = (ftRaster, ftDevice, ftTrueType);

(*----------------------------------------------------------------------------------*)

  TFONTInfo = class

  private

    FShortName : string;

    FFullName  : string;

    FStyle     : string;

    FLF        : TLogFONT;

    FFONTType  : TFONTType;

    FTM        : TNewTextMetric;

  public

    property FullName  : string         read FFullName ;

    property ShortName : string         read FShortName;

    property Style     : string         read FStyle    ;

    property FONTType  : TFONTType      read FFONTType ;

    property TM        : TNewTextMetric read FTM       ;

    property LF        : TLogFONT       read FLF       ;

  end;

(*----------------------------------------------------------------------------------*)

  TFONTLIST = class

  private

    procedure ClearLIST;

    procedure AddFONT(EnumLogFONT: TEnumLogFONT; TextMetric: TNewTextMetric; FONTType: Integer);

  public

    LIST : TStringLIST;

    constructor Create;

    destructor Destroy; override;

    procedure RefreshFONTInfo;

  end;

این کد را نیز در بخش Implementation همان یونیت اضافه کنید:

{ TFONTLIST }

(*----------------------------------------------------------------------------------*)

constructor TFONTLIST.Create;

begin

  inherited Create;

  LIST := TStringLIST.Create;

  LIST.Sorted := True;

end;

(*----------------------------------------------------------------------------------*)

destructor TFONTLIST.Destroy;

begin

  ClearLIST;

  inherited Destroy;

end;

(*----------------------------------------------------------------------------------*)

procedure TFONTLIST.ClearLIST;

begin

  while LIST.Count > 0 do

  begin

    TFONTInfo(LIST.Objects[0]).Free;

    LIST.Delete(0);

  end;

end;

(*----------------------------------------------------------------------------------*)

function EnumFONTsProc(var EnumLogFONT: TEnumLogFONT; var TextMetric: TNewTextMetric; FONTType: Integer; Data: LPARAM): Integer; stdcall;

var

  FONTLIST : TFONTLIST;

begin

  FONTLIST := TFONTLIST(Data);

  FONTLIST.AddFONT(EnumLogFONT, TextMetric, FONTType);

  Result := 1;

end;

(*----------------------------------------------------------------------------------*)

procedure TFONTLIST.AddFONT(EnumLogFONT: TEnumLogFONT;  TextMetric: TNewTextMetric; FONTType: Integer);

var

  FI : TFONTInfo;

begin

  FI := TFONTInfo.Create;



  FI.FShortName := StrPas(EnumLogFONT.elfLogFONT.lfFaceName);

  FI.FFullName  := StrPas(EnumLogFONT.elfFullName);

  FI.FStyle     := StrPas(EnumLogFONT.elfStyle);

  FI.FLF        := EnumLogFONT.elfLogFONT;



  case FONTType of

    RASTER_FONTTYPE   : FI.FFONTType  := ftRaster;

    DEVICE_FONTTYPE   : FI.FFONTType  := ftDevice;

    TRUETYPE_FONTTYPE : FI.FFONTType  := ftTrueType;

  end;



  FI.FTM        := TextMetric;



  LIST.AddObject(FI.FShortName, FI);

end;

(*----------------------------------------------------------------------------------*)

procedure TFONTLIST.RefreshFONTInfo;

var

  DC: HDC;

begin

  ClearLIST;

  DC := GetDC(0);

  try

    EnumFONTFamilies(DC, nil, @EnumFONTsProc, Longint(Self));

  finally

    ReleaseDC(0, DC);

  end;

end;

اکنون ما یک لیست از فونتهای موجود در سیستم بدست میاوریم و چک میکنیم آیا فونت موردنظر وجود دارد یا نه:

procedure TForm1.Button1Click(Sender: TObject);

var

  FONTLIST : TFONTLIST;

begin

  FONTLIST := TFONTLIST.Create;

  try

    FONTLIST.RefreshFONTInfo;

    If FONTLIST.LIST.IndexOf('ms serif')<>-1 Then // نام فونت را در این خط بدهید

         begin

           ShowMessage('Found'); // در اینجا عملیات موردنظر در صورت وجود فونت را انجام دهید

         end

    Else

         begin

             // عملیات موردنظر در صورت عدم وجود فونت را در اینجا انجام دهید

         end;

  

  finally

    FONTLIST.Free;

  end;

end;

و اما در صورت عدم وجود فونت باید چکار کرد؟
دو حالت برای اینکار وجود دارد:
1- میخواهید فونت را موقتا به لیست فونتهای در دسترس ویندوز اضافه کنید. در اینصورت آنرا با استفاده از تابع <span dir=ltr>AddFontResource()</span> بار کنید.
2- میخواهید فونت را دائما به فونتهای در دسترس ویندوز اضافه کنید. در اینصورت آنرا ابتدا آنرا به فولدر Windows\Font کپی کنید، سپس با استفاده از تابع <span dir=ltr>AddFontResource()</span> بار کنید (از دفعه بعد که ویندوز اجرا شود اینکار توسط خود ویندوز انجام خواهد شد).

برای نصب فونت از کد زیر استفاده کن

AddFontResource(   'c:\windows\system\myfont.ttf' );

SendMessage(   HWND_BROADCAST,   WM_FONTCHANGE, 0, 0 );

var

    s: TStrings;

begin

    s := TStringList.Create;

    s.Assign(Screen.Fonts);

    if s.IndexOf('myfont') = -1 then

    .

    .

    .

    s.Free;

end;

بعد از then هم شما میتونید راه آقا سعید رو برای نصب فونت انتخاب کنید.این راه به همراه راه آقا سعید کوتاه ترین سینتکس برای کنترل و نصب فونت هست.

آب در کوزه و ما گرد جهان میگردیم :)

با این حساب من لقمه رو دور سرم گردوندم. البته خوب عادت استفاده از API ویندوز چیزیه که از زمان C سرم مونده. :oops:

خوب آقا مهدی راستشو اگه بخواید این عادت خیلی خوبیه که مهارت اصلی و واقعی در نوشتن برنامه برای ویندوزه که من خیلی دوست دارم منم پیدا کنم.

با تشکر از شما که من را راهنمایی فرمودید و خطاب به مدیریت سایت که شما عادت به کد
زیادی نوشتن دارید :D و آقا سعید من از کد شما استفاده کردم و برنامه کاری را که می خواستم انجام داد. :lol:

امیدوارم که بتوانم بیشتر کمک کنم :D

نقل قول:

---

نوشته شده توسط بیگدلی

خطاب به مدیریت سایت که شما عادت به کد زیادی نوشتن دارید :D :lol:

---

از حسن نظر شما و لطف بیش از حدتان به این حقیر کمال تشکر را دارم :( :roll:

نقل قول:

---

نوشته شده توسط saeed_d

برای نصب فونت از کد زیر استفاده کن

AddFontResource(   'c:\windows\system\myfont.ttf' );

SendMessage(   HWND_BROADCAST,   WM_FONTCHANGE, 0, 0 );

---

با سلام
اين كد در كجا نصب شود ودوم آيا مسير فونت موجود در سيستم لازم نيست واگر لازم است لطفا توضيح دهيد.متشكرم

نقل قول:

---

نوشته شده توسط phantasm

برای اینکه ببینی فونت روی سیستم register شده یانه میتونی از کد زیر استفاده کنی:

procedure TForm1.Button1Click(Sender: TObject);

var

r:tregistry;

b:boolean;

v:tregdatainfo;

begin

  R := TRegistry.Create(KEY_READ);

  try

    R.RootKey := HKEY_LOCAL_MACHINE;

    R.OpenKey('SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts', False);

    b:=r.GetDataInfo('name of font',v);

  finally

    R.Free;

  end;

end;

name of font اسم فونت مورد نظره.متغیر b بر اساس اینکه true باشه یا false اون چیزی که میخوای نشون میده
این کد رو توی xp نوشتم و نمیدونم روی 98 درسته یا نه :oops:

---

باسلام
من براي نصب فونت اقدام نمودم اما از & ايراد و ERROR مي دهد لطفا راهنمايي فرماييد.متشكرم.

نقل قول:

---

نوشته شده توسط ahmadi613

باسلام
من براي نصب فونت اقدام نمودم اما از & ايراد و ERROR مي دهد لطفا راهنمايي فرماييد.متشكرم.

---

:| دوست عزیز
واقعا این کدها رو همینجوری کپی کردین و انتظار دارین جواب بده ؟؟!
بجای پرانتز و : ها کدش اومده بود کافی بود ریپلیسشون کنی؛

procedure TForm1.Button1Click(Sender: TObject);

var

r:tregistry;

b:boolean;

v:tregdatainfo;

begin

  R := TRegistry.Create(KEY_READ);

  try

    R.RootKey := HKEY_LOCAL_MACHINE;

    R.OpenKey('SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts', False);

    b:=r.GetDataInfo('name of font',v);

  finally

    R.Free;

  end;

end;