Visual Basic Enumeration/Callback Routines
SetMenuItemInfo: Create a Multi-Column Font Menu
Posted:   Sunday July 6, 1997
Updated:   Monday December 26, 2011
Callback applies to:   VB5, VB6
Menu API applies to:   VB4-32, VB5, VB6
Developed with:   VB6, Windows NT4
OS restrictions:   None
Author:   VBnet - Randy Birch


SetMenuItemInfo: Menu Scroll a Standard VB Menu
SetMenuItemInfo: Custom Application Menu Colours
VB5/6 to utilize the callback routines.

vbnssetmenuiteminfo2.gif (10773 bytes)

In attempting to display a font selection menu on a system with many installed fonts, the menu, due to the number of installed fonts, often exceeds the screen height truncating the font list. This page is an extension of the code in SetMenuItemInfo: Split Long Menus into Columns. Here, we'll use the EnumFontFamilies API to populate a font menu with the added provision breaking up the menu to span multiple columns by specifying via API how many columns to display.

The AddressOf method - introduced in VB5 - is used to pass to the API the address of the EnumFontFamilies callback routine. VB4-32 does not support callbacks without a third-party message handler, so the callback routine presented here won't work for VB4-32 owners. VB4-32 users can however still use the menu methods using the slower Screen.Fonts collection to populate the menu. The principles of the SetMenuItemInfo API, and therefore the ability to split a menu, do apply to all 32-bit versions of VB.

 BAS Module Code
Place the following code into the general declarations area of a bas module:

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.
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type

Public Declare Function GetMenu Lib "user32" _
   (ByVal hwnd As Long) As Long

Public Declare Function GetMenuItemCount Lib "user32" _
   (ByVal hMenu As Long) As Long

Public Declare Function GetSubMenu Lib "user32" _
   (ByVal hMenu As Long, ByVal nPos As Long) As Long

Public Declare Function GetMenuItemInfo Lib "user32" _
    Alias "GetMenuItemInfoA" _
   (ByVal hMenu As Long, _
    ByVal un As Long, _
    ByVal b As Boolean, _
    lpmii As MENUITEMINFO) As Long

Public Declare Function SetMenuItemInfo Lib "user32" _
    Alias "SetMenuItemInfoA" _
   (ByVal hMenu As Long, _
    ByVal uItem As Long, _
    ByVal fByPosition As Long, _
    lpmii As MENUITEMINFO) As Long

Public Const MIIM_STATE As Long = &H1
Public Const MIIM_ID As Long = &H2
Public Const MIIM_SUBMENU As Long = &H4
Public Const MIIM_CHECKMARKS As Long = &H8
Public Const MIIM_TYPE As Long = &H10
Public Const MIIM_DATA As Long = &H20

Public Const MFT_RADIOCHECK As Long = &H200
Public Const MFT_STRING As Long = &H0

Public Const RGB_STARTNEWCOLUMN As Long = &H40
Public Const RGB_EMPTY As Long = &H100
Public Const RGB_VERTICALBARBREAK As Long = &H160
Public Const RGB_SEPARATOR As Long = &H800

'required for determining the number of fonts in the menu    
Public fontCount As Integer

'required because the fonts aren't returned
'sorted .. we'll need to do this ourselves 
Public fontArray() As String

'required for font API functions
'Font enumeration types  
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64

Public 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

   tmHeight As Long
   tmAscent As Long
   tmDescent As Long
   tmInternalLeading As Long
   tmExternalLeading As Long
   tmAveCharWidth As Long
   tmMaxCharWidth As Long
   tmWeight As Long
   tmOverhang As Long
   tmDigitizedAspectX As Long
   tmDigitizedAspectY As Long
   tmFirstChar As Byte
   tmLastChar As Byte
   tmDefaultChar As Byte
   tmBreakChar As Byte
   tmItalic As Byte
   tmUnderlined As Byte
   tmStruckOut As Byte
   tmPitchAndFamily As Byte
   tmCharSet As Byte
   ntmFlags As Long
   ntmSizeEM As Long
   ntmCellHeight As Long
   ntmAveWidth As Long
End Type


Public Declare Function EnumFontFamilies Lib "gdi32" Alias _
   "EnumFontFamiliesA" _
   (ByVal hDC As Long, _
    ByVal lpszFamily As String, _
    ByVal lpEnumFontFamProc As Long, _
    lParam As Any) As Long

Public Function EnumFontCountProc(lpNLF As LOGFONT, _
                                  lpNTM As NEWTEXTMETRIC, _
                                  ByVal FontType As Long, _
                                  lParam As Long) As Long

    If FontType = TRUETYPE_FONTTYPE Then
       fontCount = fontCount + 1
    End If
   'return success to the call
    EnumFontCountProc = 1

End Function

Public Function EnumFontFamTypeProc(lpNLF As LOGFONT, _
                                    lpNTM As NEWTEXTMETRIC, _
                                    ByVal FontType As Long, _
                                    LParam As Long) As Long

    Dim FaceName As String
    Dim currFontName As String
    Static currCount as Long
    If FontType = TRUETYPE_FONTTYPE Then
     'convert the returned string from Unicode to ANSI   
      FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
     'increment the current counter   
      currCount = currCount + 1
      currFontName = Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
      fontArray(currCount) = currFontName
    End If
   'return success to the call   
    EnumFontFamTypeProc = 1

End Function

Public Sub CreateFontMenu(fArray() As String, numColums As Integer)

   Dim i As Long
   Dim hSubMenu As Long
   Dim mnuItemCount As Long
   Dim breakAt As Long
  'used in determining the split columns points   
   breakAt = (UBound(fontArray) / numColums)
  'get the menu handle   
  'this is where you specify the 0-based 
  index reflecting the Font menu position
   hSubMenu = GetSubMenu(GetMenu(Form1.hWnd), 1&)
   For i = LBound(fontArray) To UBound(fontArray)
     'because the first member of the menu control
     'array needs to be present at design time, we can't load it,
     'so some special handling is required   
      If i = 1 Then
         Form1.mnuFontNames(0).Caption = fontArray(i)
        'the menu index is 0-based, so 1 has to
        'be subtracted   
         Load Form1.mnuFontNames(i - 1)
         Form1.mnuFontNames(i - 1).Caption = fontArray(i)
      End If
     'now its time to decide if a menu break is required.
     'we have to do some tweaking because of the 0-based menu array   
      If (i - 1) Mod breakAt = 0 And i > 1 Then
        'retrieve the current information for the
        'last item in the menu into an MENUITEMINFO structure.
        'True means MF_BYPOSITION.   
         mInfo.cbSize = Len(mInfo)
         mInfo.fMask = MIIM_TYPE
         mInfo.fType = MFT_STRING
         mInfo.dwTypeData = Space$(256)
         mInfo.cch = Len(mInfo.dwTypeData)
         Call GetMenuItemInfo(hSubMenu, i - 1, True, mInfo)
        'modify its attributes to the new Type,
        'telling the menu to insert a break before
        'the member in the MENUITEMINFO structure.   
        'we only want to change the style, so reset fMask   
         mInfo.fMask = MIIM_TYPE
        'add the break   
         Call SetMenuItemInfo(hSubMenu, i - 1, True, mInfo)
       End If

End Sub

Public Sub QSStrings(sArray() As String, l As Integer, r As Integer)

    Dim i As Integer
    Dim j As Integer
    Dim x As String
    Dim y As String
    i = l
    j = r
    x = sArray((l + r) / 2)

    While (i <= j)
        While (sArray(i) < x And i < r)
            i = i + 1
        While (x < sArray(j) And j > l)
            j = j - 1

        If (i <= j) Then
            y = sArray(i)
            sArray(i) = sArray(j)
            sArray(j) = y
            i = i + 1
            j = j - 1
        End If
    If (l < j) Then QSStrings sArray(), l, j
    If (i < r) Then QSStrings sArray(), i, r

End Sub
 Form Code
The form itself is simple. Add a textbox (Text1) for output display of a selected font (I set the font size to 18 points). Add a second textbox (Text2) for the ability to specify the number of columns to split the menu into. A command button is required (Command1) as is a defined but empty menu array (mnuFontNames(0)) to hold the loaded menu. Be sure to set the index of the first menu array item to 0.

The illustration shows an Options menu; this does not form part of this project, and can be ignored. However, the GetSubMenu index used in the CreateFontMenu sub will need to accurately reflect the horizontal position of the defined-but-empty font menu across your menu bar. As far as the API is concerned, the menu bar items is a 0-based collection. In the example shown, the Options menu item occupies position 0, and the Fonts item is in position 1. If you construct a menu that does not have this exact layout, be sure to change the GetSubMenu index in CreateFontMenu to reflect the actual horizontal index position of the Font menu in your project.

Option Explicit
Private Sub Command1_Click()
  'first we need to determine how many fonts
  'of the desired type will be returned.  This is
  'required to dim the font name array for sorting,
  'and to determine where to split the menu.
   EnumFontFamilies Me.hDC, vbNullString, AddressOf EnumFontCountProc, Me.hWnd

  'with the count, we can ReDim the array
   ReDim fontArray(1 To fontCount) As String

  'get the fonts into the array
   EnumFontFamilies Me.hDC, vbNullString, AddressOf EnumFontFamTypeProc, Me.hWnd

  'sort them puppies
   QSStrings fontArray(), LBound(fontArray), UBound(fontArray)

  'and make a menu out of them. Note that
  'no error checking for valid values is done here!
   CreateFontMenu fontArray(), Val((Text2.Text))
   Command1.Enabled = False
End Sub

Private Sub mnuFontNames_Click(Index As Integer)

   Text1.Font.Name = (mnuFontNames(Index).Caption)

End Sub
After saving the project, run it and enter a value into the textbox representing the number of columns to split the menu into. Then click the command button to create the font menu.


PayPal Link
Make payments with PayPal - it's fast, free and secure!


Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy


Hit Counter