Install Font? HELP!!!

Help Me!!!

I am trying to use the addfontresource api but am getting no results - the font does not appear in the font directory.

I am using this code (with Win XP):

AddFontResource(PChar('C:\SIL.ttf'));
  SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);

Could someone please tell me what I am doing wrong or suggest another method of installing and removing fonts!

Thanks :-)
siwiherAsked:
Who is Participating?
 
Russell LibbyConnect With a Mentor Software Engineer, Advisory Commented:

////////////////////////////////////////////////////////////////////////////
//   Copy the specified file to the %windir%\font path and install the font
//   Returns 0 on succes, any other number is a windows error code
////////////////////////////////////////////////////////////////////////////
function CopyAndInstallFont(FontFile: String): Integer;
var  lpWinDir:   Array [0..MAX_PATH] of Char;
begin

  // Get the windows directory
  ZeroMemory(@lpWinDir, MAX_PATH);
  GetWindowsDirectory(lpWinDir, MAX_PATH);

  // Copy the file name passed in to the path
  StrLCat(@lpWinDir, '\fonts\', MAX_PATH);
  StrLCat(@lpWinDir, PChar(ExtractFileName(FontFile)), MAX_PATH);

  // Make sure the file names arent the same
  if (StrIComp(@lpWinDir, PChar(FontFile)) <> 0) then
  begin
     if not(CopyFile(PChar(FontFile), @lpWinDir, True)) then
     begin
        // Failure
        result:=GetLastError;
        // Bail
        exit;
     end;
  end;

  // Install the font
  if (AddFontResource(@lpWinDir) = 0) then
     // Failure
     result:=GetLastError
  else
  begin
     // Notify other windows of the font change
     SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
     // Success
     result:=ERROR_SUCCESS;
  end;

end;

usage:
---------------

dwError:=CopyAndInstallFont('C:\SIL.ttf');
if (dwError = 0) then
 ShowMessage('Success')
else
 ShowMessage(SysErrorMessage(dwError));


Russell

0
 
Russell LibbySoftware Engineer, Advisory Commented:

You should be checking the error code:

var dwError: Integer;
begin

  dwError:=AddFontResource(PChar('C:\SIL.ttf'));
  if (dwError = 0) then
  begin
    dwError:=GetLastError;
   ShowMessage(SysErrorMessage(dwError));
 end;

... rest of code


Regards,
Russell

 
0
 
siwiherAuthor Commented:
Tried it - no error message and font was not installed!
0
Cloud Class® Course: Microsoft Exchange Server

The MCTS: Microsoft Exchange Server 2010 certification validates your skills in supporting the maintenance and administration of the Exchange servers in an enterprise environment. Learn everything you need to know with this course.

 
Russell LibbySoftware Engineer, Advisory Commented:

Very odd....

Can you check the return code of the call to see how many fonts were installed? (normally one).

Also, have you tried copying this font file to the appropriate folder (C:\WINDOWS\Fonts for XP, for example) and then try the call that way.

eg:

// copy file to c:\windows\fonts
if (AddFontResource(PChar('C:\windows\fonts\SIL.ttf')) = 0) then
  RaiseLastWin32Error
else
  SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);

------------

Russell

0
 
siwiherAuthor Commented:
The copy file command worked!

Would it work for other versions of windows i.e. 98, nt?

Also could you tell me how to get the current windows directory as it could be differnt from 'C:\Windows'

Thanks
0
 
KunfufaresiCommented:
Hello,

to tell you that, these are from a Delphi Jedi unit

function CheckLastChar(Value: string): string;
begin
  //Check if the last Char is a \, and add one if necessary
  if (Length(Value) > 0) and (Value[Length(Value)] <> '\') then
    Value := Value + '\';
  Result := Value;
end;

{******************************************************}

function GetWindowsDirectory: string;
begin
  Windows.GetWindowsDirectory(buf, 250);
  Result := CheckLastChar(buf);
end;

{******************************************************}

function GetSystemDirectory: string;
begin
  Windows.GetSystemDirectory(buf, 250);
  Result := CheckLastChar(buf);
end;

{******************************************************}

function GetTempPath: string;
begin
  Windows.GetTempPath(250, buf);
  Result := CheckLastChar(buf);
end;

{******************************************************}

the full unit has much more. Also there might be a way to link fonts without copying them to windows fonts folder i'll search for that.

Kunfu Faresi
0
 
siwiherAuthor Commented:
Thanks guys for all your help

>> Kunfu, it would be great if you could check that out for me.
0
 
shaneholmesCommented:
procedure TForm1.FormActivate(Sender: TObject);
var
 Dir: array[0..200] of Char;  // use MAXFILEPATH or something like thisinstead of 200
begin
  GetSystemDirectory(Dir, SizeOf(Dir)-1);
  ShowMessage(Dir);
end;

Shane
0
 
KunfufaresiCommented:
Hello,

you could try adding a key into registery at

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Fonts
or
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts
depending on your version

as a string value name as the name of the font and data name of file with full path. I've not tried this though, and it might need restart or maybe just SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0) might do the trick. Or nothing, as i remember windows works some time when you try to emurate the fonts so it might be looking into the registery every time.

Kunfu Faresi
0
 
Russell LibbySoftware Engineer, Advisory Commented:

Actually, it should be  MAX_PATH which is defined in Windows.pas, and the value is  260.

Russell
0
 
KunfufaresiCommented:
btw buf is
    buf: array[0..250] of Char;
didnt copy that one.
0
 
siwiherAuthor Commented:
>> rllibby, thanks it worked very well. Just one last question before I give you the points: Will this work on other versions of windows?

>> to all others thank you very much for your help!
0
 
Russell LibbySoftware Engineer, Advisory Commented:
Yes, by using the GetWindowsDirectory (which is the variable part), it will build the correct path:

Just finished checking on the following OS'es:

Win95/98/Me/NT/2000/XP/2003

Regards,
Russell
0
 
siwiherAuthor Commented:
Thank you very much rllibby, I think you deserve 100 points!

Thank to others for their contributions.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.