Ejemplos usando el Api de windows para Visual basic

151 - CHOOSEFONT - Commondialog de fuente

Volver al Listado Api - Anterior - Siguiente

Ejemplo que utiliza principalemnte la función api CHOOSEFONT para utilizar el diálogo común de windows para desplegar las fuentes del sistema

vista del Commondialog usando el api de windows

Una parte de este ejemplo ( para guiarme ) la saqué del ApiGuide .

El ejemplo muestra como utilizar dicha función Api para desplegar el Commondialog , pero el mismo solo servía para retornar el nombre de la fuente, sin poder recuperar y establecer los demás atributos de fuente, como por ejemplo negrita, subrayado, el tamaño, color, cursiva, tachado, etc. Cosa muy incómoda

El ejemplo lo metí en un módulo de clase, y le añadí todas las propiedades mas comunes para los atributos de la fuente, de esta manera es mas simple utilizarlo, y también poder reutilizarlo por ejemplo en otra aplicación con solo transportar el módulo de clase

El módulo tiene un solo método llamado ShowFont para llamar al cuadro de diálogo.

Por ejemplo:

Call CMDFont.ShowFont(Me)

Las propiedades que tiene declaradas el mismo son:

FontName : Nombre de la fuente
Color : color de la fuente
MinSize : Máximo valor para el tamaño en la lista
MaxSize : Mínimo valor para el tamaño en la lista
Italic : Cursiva
UnderLine : Subrayado
FontStrikethru : Fuente tachada
FontBold :Negrita
FontSize : Tamaño de la fuente
CancelError : Para ver si se presionó cancelar

vista de la lista de propiedades y métodos para manejar los atributos de las fuentes

Nota: la propiedad CancelError no funciona como el diálogo del ocx Microsoft Common dialog Control de visual basic, en donde si se establece en True y se presiona el botón de cancelar, se dispara el error 32755 para capturarlo.

Importante: De la foma en que lo hice, hay que hacer lo siguiente. Justo después de llamar al método ShowFont, SIEMPRE hay que consular el valor de la propiedad CancelError para ver si se ha presionado el botón cancelar, por ejemplo:

Call CMDFont.ShowFont(Me)

If CMDFont.cancelError Then
   MsgBox " Se presionó cancelar", vbInformation
   Exit Sub
End If

... si todo está bien sigue

Si sabes como se podría interceptar esto, me lo podés comunicar asi lo agrego. Creo que hay que utilizar un Hook para poder capturar el mismo pero no estoy seguro si abrá una forma mas simple.

Primero se lista el código del módulo de clase, y al final de la página un ejemplo de como llamarlo para cambiar los atributos de fuente a un control Label

Código fuente en un módulo de clase llamado Class1

Const FW_BOLD As Long = 700 'Constantes Const FW_NORMAL = 400 Const DEFAULT_CHARSET = 1 Const OUT_DEFAULT_PRECIS = 0 Const CLIP_DEFAULT_PRECIS = 0 Const DEFAULT_QUALITY = 0 Const DEFAULT_PITCH = 0 Const FF_ROMAN = 16 Const GMEM_MOVEABLE = &H2 Const GMEM_ZEROINIT = &H40 Const CF_PRINTERFONTS = &H2 Const CF_SCREENFONTS = &H1 Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS) Const CF_EFFECTS = &H100& Const CF_FORCEFONTEXIST = &H10000 Const CF_INITTOLOGFONTSTRUCT = &H40& Const CF_LIMITSIZE = &H2000& Const REGULAR_FONTTYPE = &H400 Const LF_FACESIZE = 32 'Types Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName As String * 31 End Type Private Type CHOOSEFONT lStructSize As Long hwndOwner As Long hDC As Long lpLogFont As Long iPointSize As Long Flags As Long rgbColors As Long lCustData As Long lpfnHook As Long lpTemplateName As String hInstance As Long lpszStyle As String nFontType As Integer MISSING_ALIGNMENT As Integer nSizeMin As Long nSizeMax As Long End Type ' Declaraciones Api Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ hpvDest As Any, _ hpvSource As Any, _ ByVal cbCopy As Long) 'esta función es para el commondialog Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" ( _ pChoosefont As CHOOSEFONT) As Long Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalAlloc Lib "kernel32" ( _ ByVal wFlags As Long, _ ByVal dwBytes As Long) As Long 'Propiedades locales para los atributos de fuentes y otros Private m_FontName As String Private m_Color As Long Private m_Flags As Long Private m_MinSize As Long Private m_MaxSize As Long Private m_Italic As Boolean Private m_FontStrikethru As Boolean Private m_UnderLine As Boolean Private m_FontBold As Boolean Private m_FontSize As Long Private m_CancelError As Boolean 'Método para abrir el CommonDialog (recibe _ el Hwnd del formulario que lo llama) Sub ShowFont(El_Form As Form) On Error GoTo ErrShowFont Dim cf As CHOOSEFONT Dim lfont As LOGFONT Dim hMem As Long Dim pMem As Long Dim ret As Long m_CancelError = False With lfont .lfHeight = 0 .lfWidth = 0 .lfEscapement = 0 .lfOrientation = 0 'Normal - Negrita .lfWeight = FW_NORMAL .lfCharSet = DEFAULT_CHARSET .lfOutPrecision = OUT_DEFAULT_PRECIS .lfClipPrecision = CLIP_DEFAULT_PRECIS .lfQuality = DEFAULT_QUALITY .lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN 'Acá se indica en la estructura el nombre de la _ fuante a desplegar en el diálogo .lfFaceName = m_FontName & vbNullChar End With hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont)) pMem = GlobalLock(hMem) Call CopyMemory(ByVal pMem, lfont, Len(lfont)) With cf .lStructSize = Len(cf) .hwndOwner = El_Form.hWnd .hDC = El_Form.hDC .lpLogFont = pMem If m_FontSize = 0 Then 'Por defecto fuenete de 12 puntos .iPointSize = 120 End If 'Los flags indican: que listará las fuentes de pantalla como de impresora. _ También los efectos, (subrayado, el color, vista previa etc..) _ También mostrará un mensaje de advertencia cuando se seleccione una _ fuente que no exista, por ejemplo si se escribe en el cuadro de tamaño _ de fuente una letra o un valor no válido 'If fuente.Flags = 0 Then .Flags = CF_BOTH Or _ CF_EFFECTS Or _ CF_FORCEFONTEXIST Or _ CF_INITTOLOGFONTSTRUCT Or _ CF_LIMITSIZE 'End If 'Color Rojo por defecto .rgbColors = m_Color .nFontType = REGULAR_FONTTYPE ' Máximo y mínimo para el tamaño If m_MinSize = 0 Then .nSizeMin = 10 Else .nSizeMin = m_MinSize End If If m_MaxSize = 0 Then .nSizeMax = 72 Else .nSizeMax = m_MaxSize End If End With ' Acá se abre el cuadro de diálogo ret = CHOOSEFONT(cf) 'si CHOOSEFONT devuelve 0 es por que hubo algún error If ret <> 0 Then Call CopyMemory(lfont, ByVal pMem, Len(lfont)) 'Asigna las propiedaes m_Color = cf.rgbColors m_Italic = CBool(lfont.lfItalic) m_Flags = cf.Flags m_MaxSize = cf.nSizeMax m_MinSize = cf.nSizeMin 'Nombre m_FontName = Left(lfont.lfFaceName, _ InStr(lfont.lfFaceName, vbNullChar) - 1) 'Subrayado y tachado m_UnderLine = CBool(lfont.lfUnderline) m_FontStrikethru = CBool(lfont.lfStrikeOut) 'tamaño de la fuente If cf.iPointSize = 0 Then If m_FontSize = 0 Then m_FontSize = 10 End If Else m_FontSize = cf.iPointSize / 10 End If 'Negrita o sin negrita If lfont.lfWeight = FW_NORMAL Then m_FontBold = False End If If lfont.lfWeight = FW_BOLD Then m_FontBold = True End If 'sale Exit Sub End If m_CancelError = True ret = GlobalUnlock(hMem) ret = GlobalFree(hMem) Exit Sub ErrShowFont: MsgBox Err.Number & " :" & Err.Description, vbCritical End Sub '---------------------------- 'Propiedades '---------------------------- 'nombre de la fuente Property Get FontName() As String FontName = m_FontName End Property Property Let FontName(Value As String) m_FontName = Value End Property 'Color Property Get Color() As Long Color = m_Color End Property Property Let Color(Value As Long) m_Color = Value End Property 'Flags Property Get Flags() As Long Flags = m_Flags End Property Property Let Flags(Value As Long) m_Flags = Value End Property 'Minimo tamaño de fuente Property Get MinSize() As Long MinSize = m_MinSize End Property Property Let MinSize(Value As Long) m_MinSize = Value End Property 'Máximo tamaño de fuente Property Get MaxSize() As Long MaxSize = m_MaxSize End Property Property Let MaxSize(Value As Long) m_MaxSize = Value End Property 'cursiva Property Get Italic() As Boolean Italic = m_Italic End Property Property Let Italic(Value As Boolean) m_Italic = Value End Property 'Fuente Tachada Property Get FontStrikethru() As Boolean FontStrikethru = m_FontStrikethru End Property Property Let FontStrikethru(Value As Boolean) m_FontStrikethru = Value End Property 'Fuente subrayada Property Get UnderLine() As Boolean UnderLine = m_UnderLine End Property Property Let UnderLine(Value As Boolean) m_UnderLine = Value End Property ' Fuente Negrita Property Get FontBold() As Boolean FontBold = m_FontBold End Property Property Let FontBold(Value As Boolean) m_FontBold = Value End Property 'Tamaño de fuente Property Get FontSize() As Long FontSize = m_FontSize End Property Property Let FontSize(Value As Long) m_FontSize = Value End Property 'cancelError Property Get cancelError() As Boolean cancelError = m_CancelError End Property Property Let cancelError(Value As Boolean) m_CancelError = Value End Property

Ejemplo para probarlo desde un formulario al presionar un CommandButton y estableciendo los atributos a un control Label

Código en el form con un Label1 y un Command1

Option Explicit 'variable para el módulo de clase Dim CMDFont As Class1 Private Sub Command1_Click() On Error GoTo ErrShowFont 'Abre el CommonDialog Call CMDFont.ShowFont(Me) If CMDFont.cancelError Then MsgBox " Se presionó cancelar", vbInformation Exit Sub Else ' Asigna al Label las propiedaes elegidas en el CommonDialog With Label1 .ForeColor = CMDFont.Color .FontItalic = CMDFont.Italic .FontBold = CMDFont.FontBold .FontSize = CMDFont.FontSize .FontStrikethru = CMDFont.FontStrikethru .FontUnderline = CMDFont.UnderLine .FontName = CMDFont.FontName End With End If Exit Sub 'Error ErrShowFont: MsgBox Err.Number & " :" & Err.Description, vbCritical End Sub Private Sub Form_Load() Set CMDFont = New Class1 End Sub Private Sub Form_Unload(Cancel As Integer) If Not CMDFont Is Nothing Then Set CMDFont = Nothing End If End Sub

Enlaces relacionados - Recursos vb6

Listado de enlaces sobre Cuadros de diálogos

Buscar en Recursos vb