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

[بیگدلی]

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

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

[مهدی کرامتی]

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

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

[saeed_d]

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


AddFontResource&#40; 'c&#58;\windows\system\myfont.ttf' &#41;;
SendMessage&#40; HWND_BROADCAST, WM_FONTCHANGE, 0, 0 &#41;;

[SyntaxCheck]

var
s&#58; TStrings;
begin
s &#58;= TStringList.Create;
s.Assign&#40;Screen.Fonts&#41;;
if s.IndexOf&#40;'myfont'&#41; = -1 then
.
.
.
s.Free;
end;

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

[مهدی کرامتی]

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

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

[SyntaxCheck]

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

[بیگدلی]

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

[saeed_d]

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

[مهدی کرامتی]

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

[ahmadi613]

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


AddFontResource&#40; 'c&#58;\windows\system\myfont.ttf' &#41;;
SendMessage&#40; HWND_BROADCAST, WM_FONTCHANGE, 0, 0 &#41;;

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

[ahmadi613]

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


procedure TForm1.Button1Click&#40;Sender&#58; TObject&#41;;
var
r&#58;tregistry;
b&#58;boolean;
v&#58;tregdatainfo;
begin
R &#58;= TRegistry.Create&#40;KEY_READ&#41;;
try
R.RootKey &#58;= HKEY_LOCAL_MACHINE;
R.OpenKey&#40;'SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts', False&#41;;
b&#58;=r.GetDataInfo&#40;'name of font',v&#41;;
finally
R.Free;
end;
end;
name of font اسم فونت مورد نظره.متغیر b بر اساس اینکه true باشه یا false اون چیزی که میخوای نشون میده
این کد رو توی xp نوشتم و نمیدونم روی 98 درسته یا نه :oops:


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

[hossein_h62]

باسلام
من براي نصب فونت اقدام نمودم اما از & ايراد و 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;