# Native Code > برنامه نویسی در Delphi > مباحث عمومی دلفی و پاسکال > سوال: نصب فونت در ویندوز 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

سلام


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


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

دانلود

----------


## karimian22

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



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

----------

