برای چک وجود فونت از یک کلاس کمکی استفاده میکنیم.
این کدها را به بخش 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> بار کنید (از دفعه بعد که ویندوز اجرا شود اینکار توسط خود ویندوز انجام خواهد شد).