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é.
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.
- Compartir respuesta
1 respuesta más de otro experto
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
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.
- Compartir respuesta
Cada vez que intentas creerte más que alguien, solo demuestras tu falta de elegancia, de educación y que aun sigues en la etapa de mojar pañales (avergüenzas a tus orígenes). - Enrique Feijóo
Lamento que sus conocimientos sean tan pocos que lo llevan a dar conceptos teóricos sin fundamento alguno, le recomiendo no confunda a los usuarios con su poesía barata que no ayudan en nada. Lo que pasa como sucede con usted en la lawebdelprogramador, no había existido alguien que le refutara sus respuesta mediocres. Al menos reconozca cuando alguien aporta algo que usted no sabe, así se aprende y por mi parte sigo aprendiendo de otros. En cuanto los pañales usted está peor, aún ha nacido para el mundo de la programación. - Eduardo Pérez Fernández
Enrique, no te canses con él. Nació subnormal y sigue. Lo que no entiendo como en Silicon Valley no se lo rifan las empresas - Julián González Cabarcos
Para usted también va retrasado mental - Eduardo Pérez Fernández
Eduardo, ¿Qué hay de VBA en utilizar una API?... También se puede utilizar la calculadora y cualquier programa desde Access y no es un proceso Access.La función DIR (que si esta en el ADN de Access) se utiliza desde VBA Y obtiene lo que el usuario desea: conocer si la fuente existe en el directorio fuentes Y lo dejo aquí para que (si tienes neuronas disponibles) puedas entender que las flautas suenan aunque sea por los estornudos de las acémilas.Espero que los moderadores o técnicos se apiaden de los usuarios y reparen el correo del foro que alguien con muy mala lecha (sobre todo cuando se ve 'con el culo al aire') se dedica a llenar de spam .. - Enrique Feijóo
Y porque no planteó la solución con código de ejemplo, no sea mediocre, profundice en VBA, que no lo diga yo. - Eduardo Pérez Fernández
Porque mi intención es aprender cosas nuevas y con soluciones 'masticadas' solo se logran hordas de seguidores en busca de limosna. Doy la información que solicitan y espero que crezca la semilla. Por cierto, si hubieras aprovechado el tiempo vivido, sabrías que para juzgar hay que estar arriba, si te esfuerzas algún día llegaras a algún sitio. - Enrique Feijóo