نوشته شده توسط
MohsenB
سلام
چرا جواب نده؟
کپی کردن رو که تو دلفی بلدین ؟ بعد از اون از این دستور استفاده کنید :
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.
نصب فونت در ویندوز 7
پاسخ با نقل قول
