Colaboración: Instalar TTF de G. Llanderas

Instalar fuentes TTF

Fecha: 13-Jul-97
Autor: Guillermo Llanderas

From: (Guillermo Llanderas) [email protected]
Date sent: Fri, 04 Jul 1997 09:32:24 +0000

Y el texto explicativo:

Rutina para instalar fuentes TTF en Windows (válido tanto para W95
como para Windows 3.X). El manejo es sencillo, sólo se debe de copiar el
fichero TTF al directorio SYSTEM de Windows y ejecutar:

fbInstalarTTF(Nombre_de_la_fuente, Fichero.TTF)

Por ejemplo, fbInstalarTTF("Courier New", "COUR.TTF")

La función devolverá True si la instaló con éxito o False en caso de
que haya habido algún problema.

Nota aclaratoria a mi consulta (es decir que yo, el Guille, le pregunté a mi tocayo):
Gg> Pero... en Win95 no se deben instalar en el directorio Fuentes?

Ya lo hace Windows95. :)

El fichero TTF se puede dejar en cualquier sitio (yo hice el ejemplo
pensando en que estaba en el directorio system para que no variase
respecto a Windows 3.X), que al arrancar de nuevo el ordenador Win95 si
ve alguna entrada en la sección FONTS del WIN.INI copia el TTF en el
directorio FONTS y borra la entrada en el ini. Después se puede borrar
el fichero TTF de SYSTEM sin problemas.

Attribute VB_Name = "InstalarTTF"
Option Explicit
'
'Modulo para Visual Basic 4 que instala un tipo de letra en Windows haciendo:
'
'     If Not fbInstalarTTF(Nombre_Fuente, Fichero_Fuente) then
'       Hubo error...
'     End If
'
'Se debe copiar el fichero TTF al directorio SYSTEM de Windows y la funcion
'crea el fichero de recursos FOT. En Windows 3.X se anhade la linea a WIN.INI
'para que siempre este disponible y se debe dejar los ficheros TTF y FOT en el
'directorio SYSTEM. En el caso de Windows 95, el fichero TTF del directorio
'SYSTEM se puede borrar despues de haber rearrancado el sistema porque el ya
'se encarga de copiar el fichero al directorio FONTS.
'
'   Autor: Guillermo de las Llanderas Fuentes       Fecha: 03/07/97
'          InterNet: [email protected]        FidoNet: 2:348/613.26
'
#If Win32 Then
  'Declaraciones para 32 bits
  Private Declare Function SendMessage Lib "user32" _
          Alias "SendMessageA" _
          (ByVal hWnd As Long, _
           ByVal wMsg As Long, _
           ByVal wParam As Long, _
           lParam As Long _
          ) As Long
  Private Declare Function WriteProfileString Lib "kernel32" _
          Alias "WriteProfileStringA" _
          (ByVal lpszSection As String, _
           ByVal lpszKeyName As String, _
           ByVal lpszString As String _
          ) As Long
  Private Declare Function GetSystemDirectory Lib "kernel32" _
          Alias "GetSystemDirectoryA" _
          (ByVal lpBuffer As String, _
           ByVal nSize As Long _
          ) As Long
  Private Declare Function CreateScalableFontResource Lib "gdi32" _
          Alias "CreateScalableFontResourceA" _
          (ByVal fHidden As Long, _
           ByVal lpszResourceFile As String, _
           ByVal lpszFontFile As String, _
           ByVal lpszCurrentPath As String _
          ) As Long
  Private Declare Function AddFontResource Lib "gdi32" _
          Alias "AddFontResourceA" _
          (ByVal lpFilename As String _
          ) As Long
#Else
  'Declaraciones para 16 bits
  Private Declare Function SendMessage Lib "User" _
          (ByVal hWnd As Integer, _
           ByVal wMsg As Integer, _
           ByVal wParam As Integer, _
           lParam As Any _
          ) As Long
  Private Declare Function WriteProfileString Lib "Kernel" _
          (ByVal lpApplicationName As String, _
           ByVal lpKeyName As Any, _
           ByVal lpString As Any _
          ) As Integer
  Private Declare Function GetSystemDirectory Lib "Kernel" _
          (ByVal lpBuffer As String, _
           ByVal nSize As Integer _
          ) As Integer
  Private Declare Function CreateScalableFontResource Lib "GDI" _
          (ByVal fHidden As Integer, _
           ByVal lpszResourceFile As String, _
           ByVal lpszFontFile As String, _
           ByVal lpszCurrentPath As String _
          ) As Integer
  Private Declare Function AddFontResource Lib "GDI" _
          (ByVal lpFilename As Any _
          ) As Integer
#End If

Private Const WM_FONTCHANGE = &H1D
Private Const HWND_BROADCAST = &HFFFF

'
'Funcion que instala una fuente de letra True Type en Windows (tanto en
'Windows 3.X como en Windows 95). Parametros:
'
'     vsNombreFuente : Nombre de la fuente a instalar
'     vsNombreFile   : Nombre del fichero TTF que contiene la definicion de
'                      la fuente. El fichero debe de estar en vsDirSystem.
'
'Devuelve True si la instalo con exito y False en caso contrario.
'
'Ejemplo: Call fbInstalarTTF("Garnet", "GARNET.TTF")
'
Public Function fbInstalarTTF( _
                              ByVal vsNombreFuente As String, _
                              ByVal vsNombreFile As String _
                             ) As Boolean
  On Local Error GoTo Err_fbInstalarTTF
  Dim sFicheroTTF As String   'Path y nombre del fichero TTF
  Dim sFicheroFOT As String   'Path y nombre del fichero FOT
  Dim sDirSystem  As String   'Directorio System del Windows
  Dim sTemp       As String   'Usada para obtener el directorio System
  Dim lLongPath   As Long     'Longitud de la cadena devuelta por la funcion
                              'GetSystemDirectory (0 si hubo un error)

  '
  'Llamada a la funcion del API GetSystemDirectory para obtener el directorio
  'SYSTEM de Windows. Esta funcion devuelve la longitud de la cadena devuelta
  'o 0 en caso de que haya habido un error.
  '
  sTemp = String(255, 0)
  lLongPath = GetSystemDirectory(sTemp, Len(sTemp))
  If lLongPath = 0 Then
    Call MsgBox("ERROR al obtener el directorio SYSTEM", vbOKOnly + vbCritical)
    fbInstalarTTF = False
    Exit Function
  End If
  sDirSystem = Left(sTemp, lLongPath)

  sFicheroFOT = sDirSystem & "\" & fsSoloNombre(vsNombreFile) & ".FOT"
  sFicheroTTF = sDirSystem & "\" & vsNombreFile
  '
  'Comprobacion de que existe el fichero TTF con el tipo de letra a instalar
  '
  If Not fbExisteFile(sFicheroTTF) Then
    Call MsgBox("No existe el fichero " & vsNombreFile, vbOKOnly + vbCritical)
    fbInstalarTTF = False
    Exit Function
  End If
  '
  'Si no existe el fichero FOT de la fuente, se llama a una funcion del API
  'para que la cree.
  '
  If Not fbExisteFile(sFicheroFOT) Then
    '
    'Funcion del API que crea un fichero de recursos para la fuente a instalar.
    '(normalmente es un fichero con extension FOT)
    '
    If CreateScalableFontResource(0, sFicheroFOT, vsNombreFile, _
                                  sDirSystem) = 0 Then
      'Hubo error al crear el FOT
      Call MsgBox("ERROR al crear el fichero FOT", vbOKOnly + vbCritical)
      fbInstalarTTF = False
      Exit Function
    End If
  End If
  '
  'Funcion del API que instala una fuente en Windows. Devuelve el numero de
  'fuentes que ha instalado.
  '
  If AddFontResource(sFicheroFOT) <> 1 Then
    'Hubo error al anhadir la fuente en el sistema
    Call MsgBox("ERROR al a±adir la fuente al sistema", vbOKOnly + vbCritical)
    fbInstalarTTF = False
    Exit Function
  End If
  '
  'Se envia un mensaje a todas las aplicaciones en ejecucion para indicarles
  'que se ha cambiado la tabla de fuentes del sistema.
  '
  Call SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
  '
  'Se escribe en el fichero WIN.INI del sistema, dentro de las seccion 'fonts',
  'la fuente a instalar para que al arrancar de nuevo Windows este disponible.
  '
  If WriteProfileString("fonts", vsNombreFuente & " (TrueType)", _
                        fsSoloNombre(sFicheroFOT) & ".FOT") = 0 Then
    'Hubo error al cambiar el fichero WIN.INI
    Call MsgBox("ERROR al cambiar en WIN.INI. El tipo de letra" & Chr(13) & _
                vsNombreFuente & Chr(13) & _
                "no estarß disponible la pr<=xima vez que inicie Windows", _
                vbOKOnly + vbCritical)
  End If
  fbInstalarTTF = True
  Exit Function

Err_fbInstalarTTF:
  Call MsgBox("ERROR " & CStr(Err.Number) & _
              " al intentar instalar el tipo de letra:" & Chr(13) & _
              vsNombreFuente, vbOKOnly + vbCritical)
  fbInstalarTTF = False
  Exit Function
End Function


'
'Comprueba si existe un fichero. Parametros:
'
'     vsFile : Nombre del fichero a buscar
'
' Devuelve True si existe, False si no existe
'
Private Function fbExisteFile( _
                              ByVal vsFile As String _
                             ) As Boolean
  On Local Error Resume Next
  Dim iAttr As Integer

  'Obtiene los atributos del fichero. Si este no existe, da error.
  iAttr = GetAttr(vsFile)
  If Err Then
    Err.Clear
    fbExisteFile = False
  Else
    fbExisteFile = Not CBool(iAttr AND vbDirectory)
  End If
  Exit Function
End Function


'
'Devuelve el nombre, sin la extension ni el path, de un fichero. Parametros:
'
'   vsFile : Nombre del Fichero
'
Private Function fsSoloNombre( _
                              ByVal vsFile As String _
                             ) As String
  On Local Error GoTo Err_fsSoloNombre
  Dim iCont     As Integer  'Contador para los bucles For-Next

  '
  'Primero busca la ultima aparicion del caracter '\' para deshacerse del
  'path del fichero
  '
  For iCont = Len(vsFile) To 1 Step -1
    If InStr("\", Mid$(vsFile, iCont, 1)) Then
      Exit For
    End If
  Next
  vsFile = Mid$(vsFile, iCont + 1)
  '
  'Despues busca un punto para deshacerse de la extension
  '
  For iCont = Len(vsFile) To 1 Step -1
    If InStr(".", Mid$(vsFile, iCont, 1)) Then
      Exit For
    End If
  Next
  'iCont vale 0 si no encontro ningun punto (el nombre no tiene extension)
  If iCont = 0 Then
    fsSoloNombre = vsFile
  Else
    fsSoloNombre = Left$(vsFile, iCont - 1)
  End If
  Exit Function

Err_fsSoloNombre:
  Call MsgBox("ERROR " & CStr(Err.Number) & ": " & Err.Description, _
              vbOKOnly + vbCritical)
  fsSoloNombre = ""
  Exit Function
End Function