[VBnet ComDlgs] ChooseFont: Using the ChooseFont Common Dialog API


	Visual Basic Common Dialog Routines ChooseFont: Using the ChooseFont Common Dialog API

Posted:	Friday June 09, 2006
Updated:	Monday December 26, 2011

Applies to:	VB4-32, VB5, VB6
Developed with:	VB6, Windows XP
OS restrictions:	None
Author:	VBnet - Randy Birch

Related:	ChooseFont: Using the ChooseFont Common Dialog API ChooseFont: Using the LOGFONT Structure with ChooseFont ChooseFont: Adding 'Apply' to the ChooseFont Dialog

Prerequisites

None.

If the ChooseColor dialog is one of the simplest Common Dialog APIs to call, the ChooseFont dialog has to be the most complicated. Sure, a poorly-designed application can get away with just the basics and with a minimum of code and effort, but to actually use this dialog in a meaningful way means a lot of complicated code.

This demo starts with the basics and results in the poorly-designed dialog implementation I mentioned. Why? Because without the supporting code shown in the advanced demos, your displaying of the dialog can not pre-select the user's last/current font name, size, style, type, color or other attribute. In other words, whenever the dialog is presented it's as though it is the first time shown. So while not really usable, this nonetheless shows how to implement the minimum possible version of this powerful dialog.

The photo on the right shows the form layout, which is a fair number of controls for the dialog shown below. All the checkboxes and text boxes are used to set initial values for the dialog; the result is shown by printing the name of the selected font to the picture box at the top of the form.

BAS Module Code

None.

Form Code

To a new project form add (top to bottom): a picture box (Picture 1), six check boxes (Check1 through Check6), and three text boxes (Text1, Text2, Text3). Also add a command button (Command1). The frames are optional, and the form load code will label the controls for you. With this done, add the following code to the form:

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Const LF_FACESIZE As Long = 32
Private Const CF_APPLY As Long = &H200&
Private Const CF_EFFECTS As Long = &H100&
Private Const CF_FIXEDPITCHONLY As Long = &H4000&
Private Const CF_INITTOLOGFONTSTRUCT As Long = &H40&
Private Const CF_NOVECTORFONTS As Long = &H800&
Private Const CF_PRINTERFONTS As Long = &H2
Private Const CF_SCREENFONTS As Long = &H1
Private Const CF_TTONLY As Long = &H40000
Private Const LOGPIXELSY As Long = 90

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(LF_FACESIZE) As Byte
End Type

Private Type ChooseFontType
   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

Private Type OurFontOptions
   UseApply As Boolean
   UseCallback As Boolean
   UseEffects As Boolean
   UseFixedPitchOnly As Boolean
   UseLogFont As Boolean
   UseNoVectorFonts As Boolean
   UsePrinterFonts As Boolean
   UseScreenFonts  As Boolean
   UseTrueTypeOnly As Boolean
   
   SetFontName As String
   SetFontSize As Long
   SetFontBold As Boolean
   SetFontItalic As Boolean
   SetFontUnderline As Boolean
   SetFontStrikeOut As Boolean
   SetFontColour As Long
   SetFontWeight As Long
End Type

Private Declare Function ChooseFont Lib "comdlg32.dll" _
   Alias "ChooseFontA" _
  (pChoosefont As ChooseFontType) As Long
  
Private Declare Function GetDeviceCaps Lib "gdi32" _
  (ByVal hdc As Long, _
   ByVal nIndex As Long) As Long



Private Sub Form_Load()

   Check1.Caption = "Printer Fonts"
   Check2.Caption = "Screen Fonts"
   Check3.Caption = "Fixed Pitch Only"
   Check4.Caption = "No Vector Fonts"
   Check5.Caption = "TrueType Only"
   Check6.Caption = "Use Effects"
   
   Text1.Text = "0"
   Text2.Text = "128"
   Text3.Text = "0"
   
   Command1.Caption = "Show Fonts"
   
   Picture1.AutoRedraw = True
   Picture1.Print "Sample Text"

End Sub


Private Sub Command1_Click()

   Dim ofo As OurFontOptions
      
  'populate our user-defined type with various
  'font attributes used to initialize the dialog.
  'Most are simple Boolean values indicating
  'whether a particular check box on the form
  'is checked or not.
   With ofo
      
      .UsePrinterFonts = Check1.Value = vbChecked
      .UseScreenFonts = Check2.Value = vbChecked
      .UseFixedPitchOnly = Check3.Value = vbChecked
      .UseNoVectorFonts = Check4.Value = vbChecked
      .UseTrueTypeOnly = Check5.Value = vbChecked
      .UseEffects = Check6.Value = vbChecked
      
     'this is used to select the colour of the
     'font colour box. Note that only some values
     'are valid; an colour combination that does
     'not map directly to a font colour available
     'causes the colour combo to select Black.
      .SetFontColour = RGB(Val(Text1.Text), Val(Text2.Text), Val(Text3.Text))
    
   End With

   
   If GetFontSelection(ofo) Then
   
     'update the picture box to reflect
     'the font and font attributes selected
      With Picture1
         .Cls
         .CurrentY = 40
         .Font.Strikethrough = ofo.SetFontStrikeOut
         .Font.Underline = ofo.SetFontUnderline
         .Font.Italic = ofo.SetFontItalic
         .Font.Name = ofo.SetFontName
         .Font.Size = ofo.SetFontSize
         .Font.Weight = ofo.SetFontWeight
         .ForeColor = ofo.SetFontColour
         Picture1.Print ofo.SetFontName
      End With

   End If

End Sub


Private Function GetFontSelection(ofo As OurFontOptions) As Boolean

   Dim cft As ChooseFontType
   Dim lf As LOGFONT
   Dim sFontName As String
   
   With lf
     'convert the point size to logical units
     'and assign the weight
      .lfHeight = MulDiv(ofo.SetFontSize, GetDeviceCaps(hdc, LOGPIXELSY), 72)
      .lfWeight = IIf(ofo.SetFontBold, 700, 400)
      .lfItalic = ofo.SetFontItalic
      
     'style box parameters
      .lfStrikeOut = ofo.SetFontStrikeOut
      .lfUnderline = ofo.SetFontUnderline
   End With  'lf
   
  'define required ChooseFont structure elements
   With cft

     'pointer to the logfont structure set above
      .lpLogFont = VarPtr(lf)
    
      'this form is the owner
      .lStructSize = LenB(cft)
      .hwndOwner = Me.hWnd
      .hdc = Me.hdc
  
      'the font colour - if 0 will default to black
      .rgbColors = ofo.SetFontColour
  
     'display/options flags 
      If ofo.UseEffects Then .flags = (.flags Or CF_EFFECTS)
      If ofo.UseFixedPitchOnly Then .flags = (.flags Or CF_FIXEDPITCHONLY)
      If ofo.UseNoVectorFonts Then .flags = (.flags Or CF_NOVECTORFONTS)
      If ofo.UsePrinterFonts Then .flags = (.flags Or CF_PRINTERFONTS)
      If ofo.UseScreenFonts Then .flags = (.flags Or CF_SCREENFONTS)
      If ofo.UseTrueTypeOnly Then .flags = (.flags Or CF_TTONLY)
      
   End With  'cft
               
  'display font common dialog
   If ChooseFont(cft) Then
      
     'retrive values for selected font
      sFontName = StrConv(lf.lfFaceName, vbUnicode)
      sFontName = Left$(sFontName, InStr(sFontName, Chr$(0)) - 1)
       
      ofo.SetFontBold = lf.lfWeight > 400
      ofo.SetFontColour = cft.rgbColors
      ofo.SetFontName = sFontName
      ofo.SetFontSize = -MulMul(lf.lfHeight, GetDeviceCaps(hdc, LOGPIXELSY), 72)
      ofo.SetFontItalic = lf.lfItalic
      ofo.SetFontStrikeOut = lf.lfStrikeOut
      ofo.SetFontUnderline = lf.lfUnderline
      ofo.SetFontWeight = lf.lfWeight
      
      GetFontSelection = True
      
   End If

End Function


Private Function MulDiv(arg1 As Long, arg2 As Long, arg3 As Long) As Single

   Dim tmp As Single
   
   tmp = arg2 / arg3
   tmp = arg1 * tmp
   
   MulDiv = tmp
   
End Function


Private Function MulMul(arg1 As Long, arg2 As Long, arg3 As Long) As Integer
 
  'since this is the opposite of MulDiv, I named it MulMul.
   Dim tmp As Single
   
   tmp = arg2 / arg3
   tmp = arg1 / tmp
   
   MulMul = CInt(tmp)
   
End Function

Comments

If you pass a colour value not supported by the font combo, the font combo will revert to Black. Also, pressing OK without selecting a font is not the same as pressing cancel; the return value of the call is non-0 and the subsequent code in the If condition will execute.

PayPal Link