[VBnet ComDlgs] ChooseFont: Using the LOGFONT Structure with ChooseFont


	Visual Basic Common Dialog Routines ChooseFont: Using the LOGFONT Structure with ChooseFont

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 you created the basic ChooseFont demo you saw how annoying it was to constantly re-enter the font selection preferences. Probably the most annoying thing that a poor font dialog implementation can do is 'forget' the user's font name selection forcing the user to scroll through the list again. By adding code to populate the LOGFONT structure used by the ChooseFont dialog this annoyance is eliminated.

This demo's form pretty well duplicates the form used in the basic demo, adding a few additional controls to once again populate the control prior to display. I've highlighted in Red the different code used in this demo.

BAS Module Code

None.

Form Code

To a new project form add (top to bottom): a picture box (Picture 1), eleven check boxes (Check1 through Check11), and five text boxes (Text1, Text2, Text3 for the RGB colours, Text4 and Text5 for the LOGFONT info). 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"
   Check7.Caption = "Use LOGFONT Data"
   Check8.Caption = "Italic"
   Check9.Caption = "Bold"
   Check10.Caption = "Strikeout"
   Check11.Caption = "Underline"
   
   
   Text1.Text = "0"
   Text2.Text = "128"
   Text3.Text = "0"
   Text4.Text = "20"
   Text5.Text = "Times New Roman"
   
   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
      .UseLogFont = Check7.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))
    
      
     'the rest of the attributes
      .SetFontItalic = Check8.Value = 1
      .SetFontBold = Check9.Value = 1
      .SetFontStrikeOut = Check10.Value = 1
      .SetFontUnderline = Check11.Value = 1
      .SetFontName = Text5.Text
      .SetFontSize = Val(Text4.Text)
   
   End With

   
   If GetFontSelection(ofo) Then
   
     'update the controls to reflect
     'the font and font attributes selected
      Text4.Text = ofo.SetFontSize
      Text5.Text = ofo.SetFontName
      Check8.Value = Abs(ofo.SetFontItalic)
      Check9.Value = Abs(ofo.SetFontBold)
      Check10.Value = Abs(ofo.SetFontStrikeOut)
      Check11.Value = Abs(ofo.SetFontUnderline)
   
     'and update the picture box
      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
   
  'initialize the LOGFONT structure elements.
  'convert a font name into a byte array
   Call StrToByteArray(ofo.SetFontName, lf)
   
   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.UseLogFont Then .flags = (.flags Or CF_INITTOLOGFONTSTRUCT)
      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
      
     'retrieve 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
 
   Dim tmp As Single
   
   tmp = arg2 / arg3
   tmp = arg1 / tmp
   
   MulMul = CInt(tmp)
   
End Function


Private Function StrToByteArray(sFont As String, lf As LOGFONT) As Long

   Dim cnt As Long
   Dim max As Long
   
   max = Len(sFont)
   
   If max > 0 Then
   
      For cnt = 0 To max - 1
          lf.lfFaceName(cnt) = Asc(Mid$(sFont, cnt + 1, 1))
      Next
      
      StrToByteArray = max > 0
   
   End If

End Function

Comments

The same caveats apply to this demo as with the basic demo: 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