Instalar Fuente (tipo letra) desde botón vba Access

Estoy intentando programar un botón en un formulario de Access que verifique si está instalada una tipografía (fuente ttf de windows) y en caso de no existir que la instalé.

2 Respuestas

Respuesta
1

Que respuesta tan incoherente, indica la falta de conocimientos en VBA.

Copie este código en un módulo

Public Function FuenteInstalada(sFuente As String) As Boolean
   'Esta referencia ya debería estar configurada por defecto
   ' Herramientas > Referencias >OLE Automation
    Dim NewFont As StdFont
    On Error Resume Next
    Set NewFont = New StdFont
    With NewFont
        'Asignar el nombre de fuente propuesto
        ' No se asignará si la fuente no existe
        .Name = sFuente
        'Devuelve verdadero si la asignación de fuente tuvo éxito(masculine)
        FuenteInstalada = (StrComp(sFuente, .Name, vbTextCompare) = 0)
        ' devuelve el nombre de fuente real a través de los argumentos
        sFuente = .Name
    End With
End Function

Ejemplo de llamada desde el editor VBA.

¿

? FuenteInstalada("Arial")

En mi pc retorna: Verdadero

Es decir la fuente está instalada.

Observe que necesita referencia a OLE automation, por lo regular siempre está activado.

Le complemento con este ejemplo donde utilizo la función

CÓDIGO DEL BOTÓN VALIDAR

Private Sub btnValidar_Click()
 On Error GoTo hay_error
  Dim result As Long
  Dim validafuente As Boolean
  If IsNull(Me.ctlFuente) Or Me.ctlFuente = "" Then
    MsgBox "No indicado la ruta y nombre de la fuente", vbInformation, "Cuidado.."
    Exit Sub
  End If
   validafuente = FuenteInstalada(Me.ctlFuente)
  If validafuente Then
    MsgBox "La fuente está instalada", vbInformation, "Le informo"
    Exit Sub
  Else
    If MsgBox("¿Instala la fuente?", vbQuestion + vbYesNo + vbDefaultButton2, "Instala fuente") = vbNo Then
      Exit Sub
    Else
     result = AddFontResource(Me.ctlFuente & ".ttf")
        If Err.Number = 0 Then
          MsgBox "Fuente instalada satisfactoriamente", vbInformation, "Le cuento"
        End If
    End If
  End If
hay_error_exit:
  Exit Sub
hay_error:
    MsgBox "Ocurrión el error " & Err.Description & vbCrLf & Err.Description, vbCritical, "Error..."
    Resume hay_error_exit
End Sub

Observe como utilizo la función para verificar si la fuente esta instalada.

CÓDIGO DE LA FUNCIÓN (Observe la API)

Option Compare Database
Option Explicit
Declare PtrSafe Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Declare PtrSafe Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long
Public Function FuenteInstalada(sFuente As String) As Boolean
' Función para determinar si una fuente está instalada
' Ejemplo de llamada:
'                    FuenteInstalada("Arial")
   'Esta referencia ya debería estar configurada por defecto
   ' Herramientas > Referencias >OLE Automation
    Dim NewFont As StdFont
    On Error Resume Next
    Set NewFont = New StdFont
    With NewFont
        'Asignar el nombre de fuente propuesto
        ' No se asignará si la fuente no existe
        .Name = sFuente
        'Devuelve verdadero si la asignación de fuente tuvo éxito
        FuenteInstalada = (StrComp(sFuente, .Name, vbTextCompare) = 0)
        ' devuelve el nombre de fuente real a través de los argumentos
        sFuente = .Name
    End With
End Function

Nota

Las API's le sirven para instalar y remover fuentes.

Buenas tardes, Eduardo. Tengo construida todo la programación que me propones y efectivamente funciona, es decir, valida el SI/NO está instalada la fuente y si no está, he modificado el código para que la instale desde una ruta concreta C:\......\....ttf, pero me sale un mensaje de error que dice: <No hay nigún programa registrado para abrir este documento>. Realmente, lo que me interesa es configurar un botón dentro de un formulario que llame con un FolloHyperlink al archivo ttf que tengo alojado en una ruta de C:, y lo instale, pero sale ese error que te comento. Gracias

No puede utilizar FolloHyperlink, toda vez que es para abrir aplicaciones y un archivo ttf no los es.

He modificado el ejemplo para tomar el archivo fuente desde la carpeta que elija:

Si hago clic en botón carpeta obtengo:

Selecciono la primera fuente (ebrima).

Hago clic en el botón Validar:

Me dice que la fuente está instalada, hago clic en Aceptar.

Ahora voy a seleccionar la otra fuente (ebrimabd). Hago clic en Validar.

Como la fuente no está instalada pregunta si la instalo:

En estas condiciones el código cambia.
Adicione en un módulo este código;

Option Compare Database
Option Explicit
Declare PtrSafe Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Declare PtrSafe Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long
Public Function selectArchivo() As String
    'Creamos un control de errores
    On Error GoTo sol_err
    'Declaramos las variables
    Dim vFD As Object 'vFD=FileDialog
    Dim vRutaIni As String
    'Difinimos la ruta inicial
    vRutaIni = Application.CurrentProject.Path
    'Creamos el objeto FileDialog
    Set vFD = Application.FileDialog(msoFileDialogFilePicker)
    'Configuramos las características de nuestra ventana de dialogo
    With vFD
        .Title = "Seleccione el archivo de la copia de seguridad"
        .ButtonName = "A seleccionado el Archivo"
        .InitialView = msoFileDialogViewSmallIcons
        .InitialFileName = vRutaIni
        .Filters.Add "Archivos ttf", "*.ttf"
        'Detectamos el boton pulsado por el usuario
        If .Show = -1 Then
            'Asignamos a la función la carpeta seleccionada, convirtiendola a un valor de tipo String
            selectArchivo = CStr(.SelectedItems.Item(1))
        Else
            'Si se pulsa cancelar avisamos y salimos
            MsgBox "Ha cancelado la selección", vbOKCancel Or vbExclamation Or vbMsgBoxSetForeground, "Access"
            Exit Function
        End If
    End With
Salida:
    Exit Function
sol_err:
    MsgBox "Se ha producido un error: " & Err.Number & " - " & Err.Description
    Resume Salida
End Function
Public Function FuenteInstalada(sFuente As String) As Boolean
' Función para determinar si una fuente está instalada
' Ejemplo de llamada:
'                    FuenteInstalada("Arial")
   'Esta referencia ya debería estar configurada por defecto
   ' Herramientas > Referencias >OLE Automation
    Dim NewFont As StdFont
    On Error Resume Next
    Set NewFont = New StdFont
    With NewFont
        'Asignar el nombre de fuente propuesto
        ' No se asignará si la fuente no existe
        .Name = sFuente
        'Devuelve verdadero si la asignación de fuente tuvo éxito
        FuenteInstalada = (StrComp(sFuente, .Name, vbTextCompare) = 0)
        ' devuelve el nombre de fuente real a través de los argumentos
        sFuente = .Name
    End With
End Function

En el botón carpeta para buscar el archivo, ingrese este código en el evento Al hacer clic:

Private Sub btnArchivo_Click()
   Me.ctlFuente = selectArchivo()
End Sub

Ingrese este código en evento Al hacer clic del botón Validar.

Private Sub btnValidar_Click()
 On Error GoTo hay_error
  Dim result As Long
  Dim validafuente As Boolean
  Dim strSoloArchivo As String
  Dim fso As New Scripting.FileSystemObject
  If IsNull(Me.ctlFuente) Or Me.ctlFuente = "" Then
    MsgBox "No indicado la ruta y nombre de la fuente", vbInformation, "Cuidado.."
    Exit Sub
  End If
   strSoloArchivo = fso.GetBaseName(Me.ctlFuente) 'Obtengo solo el nombre del archivo sin extensión
   validafuente = FuenteInstalada(strSoloArchivo)
  If validafuente Then
    MsgBox "La fuente está instalada", vbInformation, "Le informo"
    Exit Sub
  Else
    If MsgBox("¿Instala la fuente?", vbQuestion + vbYesNo + vbDefaultButton2, "Instala fuente") = vbNo Then
      Exit Sub
    Else
     result = AddFontResource(Me.ctlFuente & ".ttf")
        If Err.Number = 0 Then
          MsgBox "Fuente instalada satisfactoriamente", vbInformation, "Le cuento"
        End If
    End If
  End If
hay_error_exit:
  Exit Sub
hay_error:
    MsgBox "Ocurrión el error " & Err.Description & vbCrLf & Err.Description, vbCritical, "Error..."
    Resume hay_error_exit
End Sub

Observe que es diferente a lo expuesto anteriormente, ahora requiere del botón para buscar archivos ttf y FileSystemObject para obtener del método GetBaseName el nombre del archivo sin extensión, porque así lo requiere la función FuenteInstalada().

No olvide en referencias, hacer referencia a Microsoft Scripting Runtime.

Respuesta
-1

Se puede utilizar la función DIR para indagar si ya esta en el directorio FONTs.

Creo que es mas sencillo intentar instalarla y que sea el sistema el que la rechace al no permitir duplicidades.

Tampoco se debería perder de vista que en muchas ocasiones los usuarios carecen de permisos para instalar recursos en sus maquinas en directorios que no sean propios.

La pregunta curiosa es:
¿Esa instalación no debería hacerse en el momento de instalar la aplicación?, los programas que hay para ello acostumbran a permitir instalaciones condicionadas.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas