نصب فونت در ویندوز 7

[Mask]

با عرض سلام و خسته نباشید.
در ویندوز xp یه روال نوشته بودم که باهاش فونتهای برنامه رو نصب میکردم.
اما در سون جواب نمیده.
چی کارش باید کرد.
ممنون.

procedure InstallFont(PathDirFontLocal: String);
var
F : TSearchRec;
FileName : TFileName;
i:Byte;
List:TStringList;
DirFontSystem :string;
DirWin: array [0..MAX_PATH] of Char;
begin
try
GetWindowsDirectory(DirWin, MAX_PATH);
DirFontSystem :=strpas(DirWin)+'\Fonts\';
PathDirFontLocal:=IncludeTrailingBackslash(PathDir FontLocal);
List:=TStringList.Create;
try
if DirectoryExists(PathDirFontLocal)then
begin
if (FindFirst(PathDirFontLocal + '*.*',faAnyFile - faDirectory,F) = 0)then
begin
try
repeat
FileName := F.Name;
List.Add(F.Name)
until FindNext(F) <> 0;
finally
FindClose(F);
end;
end;
for i:=0 to List.Count-1 do
begin
FileSetAttr(PathDirFontLocal +List[i], faArchive);
AddFontResource(pchar(PathDirFontLocal+List[i]));
//OR CopyFile(pchar(PathDirFontLocal+List[i]),pchar(DirFontSystem + List[i]),false);
SendMessage(HWND_BROADCAST,WM_FONTCHANGE, 0, 0 );
end;
end;
finally
List.Free;
end;
except
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
InstallFont(ExtractFilePath(Application.ExeName)+' Fonts');
end;

[سعید صابری]

فکر کنم مشکل UAC باشه. چون حداقل باید کار کپی فونتها را انجام بده

[Mask]

دوستان نظری ندارند.؟

[MohsenB]

سلام

نوع فونت هایی که ویندوز 7 قبول میکنه با ایکس پی فرق میکنه .

شما باید فونتهایی که مال ویندوز 7 هست رو نصب کنید .

یه راه امتحانش اینه که خودتون بتونید اونا رو نصب کنید .


موفق باشید .

[Felony]

کد بالا فونت مورد نظر رو به Font Table اضافه میکنه و بعد از بسته شدن هم ویندوز به صورت خودکار حذفش میکنه ، برای اینکه فونت رو به صورت دائمی نصبش کنید باید در رجیستری ثبتش کنید ، یا توجه به مستندات MSDN کدتون رو تغییر دادم ( از اول نوشتم ! ) ولی تو 7 تستش نکردم ( رو سیستم ویندوز سرور نصب هست ) :

procedure InstallFont(LocalFontPath: String);
const
CSIDL_Fonts = $0014;
var
FontDir: array [0 .. MAX_PATH] of Char;
Font: string;
Reg: TRegistry;
begin
if not SUCCEEDED(SHGetFolderPath(0, CSIDL_Fonts, 0, SHGFP_TYPE_CURRENT,
@FontDir[0])) then
raise Exception.Create('Can not find system Font directory');

LocalFontPath := IncludeTrailingBackslash(LocalFontPath);

Reg := TRegistry.Create(KEY_ALL_ACCESS);
try
for Font in TDirectory.GetFiles(LocalFontPath, '*.*',
TSearchoption.soTopDirectoryOnly) do
begin
if SysUtils.FileExists(FontDir + SysUtils.ExtractFileName(Font)) then
raise Exception.CreateFmt('%s is exists in system font directory',
[SysUtils.ExtractFileName(Font)]);

TFile.Copy(Font, FontDir + SysUtils.ExtractFileName(Font));
Reg.RootKey := HKEY_LOCAL_MACHINE;
Reg.LazyWrite := False;
Reg.OpenKey('SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts', False);
Reg.WriteString(SysUtils.ExtractFileName(Font) + ' (TrueType)',
SysUtils.ExtractFileName(Font));
Reg.CloseKey;
AddFontResource(PChar(FontDir + SysUtils.ExtractFileName(Font)));
end;
finally
Reg.Free;
end;
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;

برای استفاده از کد ، کتابخانه های IOUtils و Types رو به برنامه اضافه کنید .

اگر مشکل داشت بگید تا بررسیش کنم .

در ضمن ، اون کدی که در پست اول قرار دادی عملا Spaghetti Code هست !

[arkia]

برای استفاده از کد ، کتابخانه های IOUtils و Types رو به برنامه اضافه کنید .

اگر مشکل داشت بگید تا بررسیش کنم .


وکتابخانه ی SHFolder :لبخندساده:

[arkia]

جواب نمیده مخصوصا تو سون ، من یه فایل دسته ای (.bat) درست کردم که کار کپی و رجیستری رو انجام میده اما یه مشکلی هست اول اینکه باید ریست بشه تا فونتا بیان دوم اینکه وقتی روش کلیک میکنی خوب کار میکنه ها اما وقتی با دستور shellexecute اجراش میکنم خطا میده چکار کنم ؟



Install.bat:

@title Install Fonts
@copy *.ttf %systemroot%\fonts
@fonts.reg
@pause

fonts.reg:
Windows Registry Editor Version 5.00

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts]
"B Titr Bold (TrueType)"="B Titr Bold.TTF"
"B Traffic Bold (TrueType)"="B Traffic Bold.TTF"
"B Traffic (TrueType)"="B Traffic.TTF"
"B Zar Bold (TrueType)"="B Zar Bold.TTF"
"B Zar (TrueType)"="B Zar.TTF"

[MohsenB]

سلام

ببینید یه راه خیلی خیلی سادش اینه که شما فونت ها رو تو پوشه فونت ویندوز کپی کنید بعد پوشه رو تو اکسپلورر نشون بدین ( یعنی یه بار پوشه رو باز کنید Explorer %WinDir%\Fonts ) خود ویندوز نصبشون میکنه .

یعنی کدتون اینجوری میشه :

Install.bat:

@title Install Fonts
@copy *.ttf %systemroot%\fonts
explorer %systemroot%\fonts

البته من از این systemroot ی که نوشتین مطمئن نیستم ، فکر کنم قدیما همون windir رو میزاشتم . تو راهنمای ویندوز یه جستجو بکنید


موفق باشید

[arkia]

اینم جواب نمیده (چون اگه نصب و رجیسترش از این طریق هم درست بشه توی دلفی نمیشه اجراش کرد) اگه میشه یه روشی بگید که هم تو XP و هم تو Seven بتونم فونتامو نصب کنم

[MohsenB]

اینم جواب نمیده (چون اگه نصب و رجیسترش از این طریق هم درست بشه توی دلفی نمیشه اجراش کرد) اگه میشه یه روشی بگید که هم تو XP و هم تو Seven بتونم فونتامو نصب کنم

سلام

چرا جواب نده؟

کپی کردن رو که تو دلفی بلدین ؟ بعد از اون از این دستور استفاده کنید :

ShellExecute(0,nil ,'Explorer' , 'C:\Windows\Fonts',nil,SW_SHOWNOACTIVATE);

فقط شما جای C:\Windows از دستوراتی که برای پیدا کردن فولدر ویندوز وجود داره استفاده کنید و جایگزین کنید .


موفق باشید

[Mask]

سلام

چرا جواب نده؟

کپی کردن رو که تو دلفی بلدین ؟ بعد از اون از این دستور استفاده کنید :

ShellExecute(0,nil ,'Explorer' , 'C:\Windows\Fonts',nil,SW_SHOWNOACTIVATE);

فقط شما جای C:\Windows از دستوراتی که برای پیدا کردن فولدر ویندوز وجود داره استفاده کنید و جایگزین کنید .


موفق باشید

دوست عزیز .نصب فونت در ویندوز سون با xp فرق میکنه. فرقش رو آقای تاجیک گفتند.
فرقش اینه که در win xp فقط کپی کردن فونت کفایت میکرد.اما در سون باید فونتها در رجیستری هم رجیستر بشه.
از کد زیر استفاده کنید: هم در سون و هم در xp کار میکنه : و هم از دلفی 7 به بالا:لبخندساده:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,Types,Registry, StdCtrls, ComCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
ProgressBar1: TProgressBar;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

function ExtractOnlyFileName(const FileName: string): string;
var
I: Integer;
S:string;
begin
S:=ExtractFileName(FileName);
I := LastDelimiter('.' + PathDelim + DriveDelim, S);
if (I > 0) and (S[I] = '.') then
Result := Copy(S,0, I-1) else
Result := '';
end;

procedure SetRegStr(Root:HKEY;Key,Value,Data:string);
var R:TRegistry;
begin
try
R:=TRegistry.Create;
try
R.RootKey:=Root;
R.OpenKey(Key,True);
R.WriteString(Value,Data);
finally
R.CloseKey;
R.Free
end;
except
ShowMessage('Write to Registry Error');
halt;
end;
end;

procedure InstallFont(LocalFontPath: String);
var
F : TSearchRec;
FileName : TFileName;
i:Byte;
List:TStringList;
DirFontSystem :string;
WinDir: Array[0..MAX_PATH -1] of char;
Result: string;
begin
SetString(Result,winDir,GetWindowsDirectory(WinDir ,MAX_PATH));
try
DirFontSystem :=WinDir+'\Fonts\';
LocalFontPath:=IncludeTrailingBackslash(LocalFontP ath);
List:=TStringList.Create;
try
if DirectoryExists(LocalFontPath)then
begin
if (FindFirst(LocalFontPath + '*.*',faAnyFile - faDirectory,F) = 0)then
begin
try
repeat
FileName := F.Name;
List.Add(F.Name)
until FindNext(F) <> 0;
finally
FindClose(F);
end;
end;
for i:=0 to List.Count-1 do
begin
FileSetAttr(LocalFontPath +List[i], faArchive);
CopyFile(pchar(LocalFontPath+List[i]),pchar(DirFontSystem + List[i]),false);
SetRegStr(HKEY_LOCAL_MACHINE,'SOFTWARE\Microsoft\W indows NT\CurrentVersion\Fonts',ExtractOnlyFileName(List[i])+' (TrueType)',List[i]);
Form1.ProgressBar1.Position:=form1.ProgressBar1.Po sition+1;
end;
end;
finally
List.Free;
Form1.ProgressBar1.Position:=100;
ShowMessage('install fonts complit');
end;
except
ShowMessage('error');
Application.Terminate;
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
InstallFont(ExtractFilePath(Application.ExeName)+' fonts');
end;

end.

[arkia]

سلام

چرا جواب نده؟

کپی کردن رو که تو دلفی بلدین ؟ بعد از اون از این دستور استفاده کنید :

ShellExecute(0,nil ,'Explorer' , 'C:\Windows\Fonts',nil,SW_SHOWNOACTIVATE);

فقط شما جای C:\Windows از دستوراتی که برای پیدا کردن فولدر ویندوز وجود داره استفاده کنید و جایگزین کنید .


موفق باشید

سلام، این چه کاریه که بیایم مسیر فونت ها رو باز کنیم؟ واسه Refresh یا Update شدن لیست فونت ها این کار رو انجام بدم؟ منن این کارو با کد زیر انجام دادم :


SendMessage(HWND_BROADCAST, WM_FONTCHANGE,0,0);


اما برنامم هنگ کرد اما با کد زیر درست شد


postMessage(HWND_BROADCAST, WM_FONTCHANGE,0,0);


ولی بازم به ریستارت نیاز داره! :متفکر:

کار کپی و نوشتن تو رجیستری رو بلدم اما من دنبال روشی بودم که آنی نصب بشه و به ریست نیازی نداشته باشه اون فایل دسته ای هم نوشتم دیدم بازم همینه
راستی من هنوز نمیتونم فایل دسته ای رو تو دلفی باز کنم باز میشه ها اما خطا میده

[MohsenB]

سلام، این چه کاریه که بیایم مسیر فونت ها رو باز کنیم؟ واسه Refresh یا Update شدن لیست فونت ها این کار رو انجام بدم؟ ...

سلام

من که همون اول گفتم که "این یک روش خیلی خیلی ساده هست" ( که البته مخصوص ویندوز xp هست ) شما از هر روشی که خواستین استفاده کنید .


موفق باشید

[Mask]

ویندوز سون حتما باید ریست بشه.

[hp1361]

با سلام

خواستم بدونم چطور میشه فونت رو از سیستم حذف کرد؟

من فایل رو هم توی پوشه فونت ها و هم توی رجیستری میبینم و با دستور هم تایید پیدا کردنش رو میده اما دستور دیلیت چیزی رو حذف نمیکنه!


لطفا راهنمایی کنید

ممنون

[hp1361]

سلام مجدد

ویندوز xp

همچین کدی نوشتم


deletefile(fontdir+'tahoma.ttf');


البته وقتی وجودشو چک میکنم اوکی میده اما حذفش نمیکنه!

[hp1361]

منکه عرض کردم پوشه فونت سیستم رو چک میکنه

اینم کد برای مطمئا شدن


procedure TForm_Main.BitBtn_DeleteFontsClick(Sender: TObject);
var
F : TSearchRec;
FileName : TFileName;
i:Byte;
List:TStringList;
DirFontSystem :string;
WinDir: Array[0..MAX_PATH -1] of char;
Result: string;
begin
SetString(Result,winDir,GetWindowsDirectory(WinDir ,MAX_PATH));
DirFontSystem :=WinDir+'\Fonts\';
// LocalFontPath:=IncludeTrailingBackslash(LocalFontP ath);
if FileExists(DirFontSystem+'Skoodkbd.ttf') then
ShowMessage('existed');

if (System.SysUtils.DeleteFile(DirFontSystem+'Skoodkb d.ttf)')) then
ShowMessage('deleted')
else
ShowMessage('no deleted');
end;

[Mask]

شما نام فونتتو از این قسمت رجیستری اول حذف کن. درست میشه.

SetRegStr(HKEY_LOCAL_MACHINE,'SOFTWARE\Microsoft\W indows NT\CurrentVersion\Fonts'

[hp1361]

سلام

نام فونت مورد نظر رو از رجیستری حذف کردم اما باز هم نشد!


regkey.DeleteValue('Akram (True Type)')

البته بقیه کدهارو ننوشتم!

مشکل کجاست؟

[hp1361]

سلام

اینکه نمیتونستم فایل رو حذف کنم به خاطر این بود که خاصیت Read-only اش تیک خورده بود!با SetAttr مقدارشو نرمال کردم و بعدش حذفش کردم!


سوال:آیا میشه همه فونت هاتی سیستم رو حذف کرد؟آیا ویندوز همچین اجازه ای رو میده؟اگه حذف بشه خودش دوباره ضروری ها رو برمیگردونه یا ویندوز از کار می افته؟

[arkia]

سلام

اینکه نمیتونستم فایل رو حذف کنم به خاطر این بود که خاصیت Read-only اش تیک خورده بود!با SetAttr مقدارشو نرمال کردم و بعدش حذفش کردم!




ویندوزت چیه؟

[hp1361]

سلام

ویندوزم XP بود.البته من میخوام برای ویندوز سرور2003 و 2008 هم انجام بدم و البته 7

[zidane]

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

[zidane]

اين هم سورس:

[hp1361]

سلام

میشه نوع ارجاع List رو برام توضیح بدید؟و همچنین دلیل تغییر نوعش؟

اینجا TStringList هستش

procedure InstallAllFonts;
var
List:TStringList;
begin
List:=TStringList.Create;
FindFiles(ExtractFilePath(Application.ExeName),'*. ttf',List);
InstallFonts(List);
List.Free;
end;


اما اینجا TStrings

procedure FindFiles(StartDir, FileMask: string; FilesList:TStrings);
var
SR: TSearchRec;
DirList: TStringList;
IsFound: Boolean;
i: integer;
begin
if StartDir[length(StartDir)] <> '\' then
StartDir := StartDir + '\';

{ Build a list of the files in directory StartDir(not the directories!) }

IsFound :=FindFirst(StartDir + FileMask, faAnyFile - faDirectory, SR) = 0;
while IsFound do
begin
FilesList.Add(StartDir + SR.Name);
IsFound := FindNext(SR) = 0;
end;
FindClose(SR);

// Build a list of subdirectories
DirList := TStringList.Create;
IsFound := FindFirst(StartDir + '*.*', faAnyFile, SR) = 0;
while IsFound do
begin
if ((SR.Attr and faDirectory) <> 0) and (SR.Name[1] <> '.') then
DirList.Add(StartDir + SR.Name);
IsFound := FindNext(SR) = 0;
end;
FindClose(SR);

// Scan the list of subdirectories
for i := 0 to DirList.Count - 1 do
FindFiles(DirList[i], FileMask,FilesList);

DirList.Free;
end;

[یوسف زالی]

سلام.
دلیلش چند ریختی یا PolyMorphism هست.
شما می تونید در این حالت آبجکتهای مشتق شده از TStrings رو بهش بدید. مثل Items کمبو یا Lines ممو.

[hp1361]

ممنون

اما قسمت اول سوالمو چیزی نگفتید(البته قسمت اول هم دلیلش رو خواستم،اینکه چرا از اول از همون Tstrings استفاده نکردند)

اینکه برای ارجاع با رفرنس احتیاج به نوشتن Var هست اما در اینجا ازش استفاده نشده!


FindFiles(ExtractFilePath(Application.ExeName),'*. ttf',List);
InstallFonts(List);



procedure FindFiles(StartDir, FileMask: string; FilesList:TStrings);


فکر کنم یادم اومد!
استرینگ ها اشاره گر هستند و ارجاع اشاره گر همون ارجاع با رفرنس هستش!

[یوسف زالی]

TStrings کلاسی نیست که بتونید ازش شی بسازید. نه اینکه اصلا نتونید. در حقیقت برای این کارها نیست.
چون پیاده سازی آیتم هاش رو موکول کرده به کلاسهای فرزند. اگر به تعریفش نگاه بندازید می بینید که اجزای Abstract داره.
String ها اشاره گر نیستند.
قانون:
تمام اشیا در حالت پارامتری فقط Pointer شون پاس داده می شه.

[Felony]

String ها اشاره گر نیستند.
چرا هستن ، برای همین هست که وقتی با تابع SizeOf اندازه یک متغییر رشته ای رو واکشی میکنیم بدون توجه به مقدار رشته ( یعنی چه خالی باشه چه چند هزار کاراکتر داخلش باشه ) اندازه برابر با 4 هست که سایز Pointer ی هست که به اون رشته در حافظه اشاره میکنه نه سایز Data اون رشته .

البته این فقط مربوط به رشته ها نمیشه و Object ها ، Interface ها و Dynamic Array ها هم مثل String ها در پشت صحنه فقط یک اشاره گر هستند و واقعا حاوی اطلاعاتن مربوطه نیستند و برای همین هم هست که برای گرفتن طول رشته ها و Dynamic Array ها تابع Length و برای اشیاء متد InstanceSize در نظر گرفته شده .

در کل رشته ها Data Type های بسیار جالبی در Delphi هستند ، آقای کشاورز مقاله ای در سایتشون در این مورد قرار داده بودند که بسیار روان نوشته شده بود ولی سایتشون فعلا غیر فعال هست ، میتونید ازشون درخواست کنید در صورت امکان مقاله رو در اختیارتون بزارن .

موفق باشید .

[hp1361]

سلام مجدد



تمام اشیا در حالت پارامتری فقط Pointer شون پاس داده می شه.


خوب چجوری بفهمیم در حالت پارامتری ارجاع داد شده یا غیر پارامتری؟(تا اونجایی که من از دلفی یادم میاد برای ارجاع با رفرنس از Var استفاده میشد در غیر این صورت ارجاع با مقدار بود،اما در کدهای بالا اینطور نیست)

[یوسف زالی]

منظور من از رشته ها اینه که وقتی ارسال می شن به متد اشاره گرشون فرستاده نمی شه.

قانونش رو گفتم دیگه. اگر شی بود همیشه ارجاع هست. برای انواع داده ای ساده که روی Stack حافظه می گیرن ارجاع نیست مگر اینکه تصریح بشه.

[Felony]

پست ها رو دقیق مطالعه کردید ؟ اشیاء یک Object هستن ، Object ها اشاره گر هستند ، پس نیازی به پاس دادن به وسیله Var نیست ، شما وقتی یک شئ رو به عنوان یک پارامتر پاس میدید در حقیقت دارید آدرس اون رو به تابع میدید و تابع هم مستقیم با خود شئ کار میکنه نه یک کپی از اون شئ پس تغییرات کستقیم روی اون شئ اعمال میبشه .

[MohsenB]

سلام


یه یونیت تغریبا کامل برای فونت نوشتم که تقدیم به همه میکنم


موفق و پیروز باشید

دانلود (https://dl.dropboxusercontent.com/u/19949757/MSFontTools.zip)

[karimian22]

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


دقیقا درست کار می کنه... (ممنون)