type 
  TGetFontResourceInfoW = function(Name: PWideChar; var BufSize: Cardinal; 
    Buffer: Pointer; InfoType: Cardinal): LongBool; stdcall; 
 
function FontNameFromFile(FontDatei: WideString): string; 
var 
  RIW: TGetFontResourceInfoW; 
  AFR, I: Integer; 
  LF: array of TLogFontW; 
  SZ: Cardinal; 
  HF: HFONT; 
begin 
  RIW := GetProcAddress(GetModuleHandle('gdi32.dll'), 'GetFontResourceInfoW'); 
  if @RIW = nil then 
    raise Exception.Create('GetFontResourceInfoW in GDI32.dll nicht gefunden.'); 
  AFR := AddFontResourceW(PWideChar(FontDatei)); 
  try 
    if AFR > 0 then 
    begin 
      SetLength(LF, AFR); 
      SZ := AFR * SizeOf(TLogFontW); 
      if not RIW(PWideChar(FontDatei), SZ, @LF[0], 2) then 
        raise Exception.Create('Fehler bei GetFontResourceInfoW aufgetreten.'); 
      AFR := SZ div SizeOf(TLogFont); 
      for I := 0 to pred(AFR) do 
      begin 
        HF := CreateFontIndirectW(LF[I]); 
        try 
          Result := LF[I].lfFaceName; 
        finally 
          DeleteObject(HF); 
        end; 
      end; 
    end; 
  finally 
    RemoveFontResourceW(PWideChar(FontDatei)); 
  end; 
  if Result = '' then 
    raise Exception.Create('Nichts gefunden.'); 
end; 
 
 
// Beispielaufruf 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  showmessage(FontNameFromFile 
      ('I:\offc\Office\FILES\WINDOWS\FONTS\IMPRISHA.TTF')); 
end;