Visual Basic Menu API Routines
SetMenuItemInfo: Menu Scroll a Standard VB Menu
     
Posted:   Saturday February 15, 2003
Updated:   Monday December 26, 2011
     
Applies to:   VB4-32, VB5, VB6
Developed with:   VB6, Windows XP
OS restrictions:   Windows 98 or later, Windows 2000 or later
Author:   VBnet - Randy Birch
     

Related:  

SetMenuItemInfo: Create a Multi-Column Font Menu
     
 Prerequisites
The MENUINFO structure is available on Win98 or later, or Win2000 or later..

Under Windows 98/ME/2000/XP or later, a scrollable menu may be shown when the height required to display all the menu items exceeds the screen height. By manually setting the cyMax member of a MENUINFO type under these OS versions, a scrollable menu of developer-defined size can be introduced into any menu in the VB application.

The demo below populates a menu with the installed TrueType fonts using a callback via EnumFontFamilies. As the system provides installed fonts in a random order, the fonts are loaded to a temporary array and the array is sorted using a QuickSort. Next, CreateFontMenu dynamically builds and populates the Fonts menu with the sorted font array data. Then the SetMenuScroll routine determines the form's client area in pixels and customizes the menu to ensure the menu will scroll when the menu height exceeds the form's client height.

And there is a very cool side effect to this: menus assigned the scroll feature retains this effect even when displayed as a popup menu providing an excellent, compact means to present a popup font menu inside a text or rich text box.

The demo calls the SetMenuScroll routine from the form load event. If you wish to have the menu always resize to fit within the client area, place the call in the form resize event instead. Then, as the window is resized, the number of menu items shown before scrolling is required will dynamically change with the window size. But note the precautions identified in the SetMenuScroll routine concerning implementing resizing in the resize event.

Because of the enumeration callback, a BAS module is required for this demo.

 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.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'required for font API functions
'font enumeration types
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64
Private Const TRUETYPE_FONTTYPE = &H4
Private Const MIM_MAXHEIGHT As Long = &H1
Private Const MNS_NOCHECK  As Long = &H80000000

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

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

Private Type MENUINFO
   cbSize As Long
   fMask As Long
   dwStyle As Long
   cyMax As Long
   hbrBack As Long
   dwContextHelpID As Long
   dwMenuData As Long
End Type

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 NEWTEXTMETRIC
   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

Private Declare Function SetMenuInfo Lib "user32" _
  (ByVal hmenu As Long, _
   mi As MENUINFO) As Long
   
Public Declare Function GetMenu Lib "user32" _
  (ByVal hwnd As Long) As Long
  
Public Declare Function GetSubMenu Lib "user32" _
  (ByVal hmenu As Long, _
   ByVal nPos As Long) As Long
   
Private Declare Function lstrlenW Lib "kernel32" _
  (ByVal lpString As Long) As Long
         

Public Function SetMenuScroll(frm As Form, ByVal hmenu As Long) As Boolean

  'Add scrollbars to the menu if the
  'menu will exceed the form ScaleHeight.
  'Note that if the form height is less than
  '960, three things could happen:
  'a) only one menu item will be visible,
  'plus the two scroll arrows.
  'b) no menu items are visible,
  'just the arrows, or
  'c) if too small for even the arrows,
  'the call is ignored and the entire
  'menu is shown.
   Dim mi As MENUINFO
   Dim tmpScalemode As Long

  'In order to calculate the menu height
  'the form is passed to this routine,
  'the form's current ScaleMode is saved
  'to a temp variable, the ScaleMode is set
  'to vbTwips, the required height is calculated
  'then the form' original ScaleMode is restored.
  
   tmpScalemode = frm.ScaleMode
   frm.ScaleMode = vbPixels
   
   With mi
      .cbSize = Len(mi)
      .fMask = MIM_MAXHEIGHT
      .cyMax = frm.ScaleHeight 'pixels!
   End With

   Call SetMenuInfo(hmenu, mi)
   
  'clean up
   frm.ScaleMode = tmpScalemode

End Function


Private Function TrimNull(startstr As String) As String

   TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr)))
   
End Function


Public Function EnumFontFamProc(lpNLF As LOGFONT, _
                                lpNTM As NEWTEXTMETRIC, _
                                ByVal FontType As Long, _
                                ByVal lparam As Long) As Long

   Static currCount As Long
    
   If FontType = TRUETYPE_FONTTYPE Then
    
      Select Case lparam
         Case False
        
           'just counting fonts!
            fontCount = fontCount + 1
           
           'reset the local static variable 
           'used when True is passed
            currCount = 0
           
        Case True
          
        'increment the counter, convert
        'the font string from Unicode to
        'ANSI and assign to array
         currCount = currCount + 1
         fontArray(currCount) = TrimNull(StrConv(lpNLF.lfFaceName, vbUnicode))

      End Select
      
   End If
   
  'either way, return success
  'to continue enumeration until done
   EnumFontFamProc = 1

End Function


Public Sub CreateFontMenu(frm As Form)

   Dim cnt As Long
   
   With frm
   
      If .mnuFonts.Count > 1 Then Exit Sub
      
      For cnt = LBound(fontArray) To UBound(fontArray)
        
         If cnt = 1 Then
            .mnuFonts(0).Caption = fontArray(cnt)
         Else
           'the menu index is 0-based, 
           'so 1 has to be subtracted
            Load .mnuFonts(cnt - 1)
            .mnuFonts(cnt - 1).Caption = fontArray(cnt)
         End If
   
      Next
   
   End With
End Sub


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

   Dim i As Long
   Dim j As Long
   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
      Wend
        
      While (X < sArray(j) And j > l)
         j = j - 1
      Wend

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

End Sub


 Form Code
Create a top-level menu item on a new form, assigning the menu name of 'zmnuFonts'. The preceding 'z' in the name ensures the little-used item sorts at the bottom of the design-time controls list, one of my personal preferences to keep clutter out of the list. Add a single empty menu item under the new menu, name it 'mnuFonts', and set that menu item's index property to 0 to create a menu array. Add the following code to the form:

Option Explicit
Private Sub Form_Load()

  'first, determine how many fonts
  'are installed in order to ReDim
  'the font name array for sorting.
  'Counting is invoked by passing
  'False as the lParam value to a
  'EnumFontFamProc callback
   Call EnumFontFamilies(Me.hDC, _
                         vbNullString, _
                         AddressOf EnumFontFamProc, _
                         ByVal False)

   If fontCount <> 0 Then
  
     'ReDim the array - might
     'as well be 1-based
      ReDim fontArray(1 To fontCount) As String

     'Call EnumFontFamilies again, this
     'time passing True as lParam in
     'order to get the installed fonts
     'into the array
      Call EnumFontFamilies(Me.hDC, _
                            vbNullString, _
                            AddressOf EnumFontFamProc, _
                            ByVal True)

     'the string return randomly so
     'require sorting for the menu
      Call QSStrings(fontArray(), _
                     LBound(fontArray), _
                     UBound(fontArray))

     'create the font menu
      Call CreateFontMenu(Me)
      
     'and restrict the menu height to
     'the initial form height. The form
     'itself is passed because the ScaleMode
     'needs to be temporarily set to Pixels.
     'GetSubMenu/GetMenu specifies the 0-based
     'position of the menu upon which to add
     'the scroll effect, in this demo the first
     'item (item 0). Adjust to suit in other applications.
      Call SetMenuScroll(Me, GetSubMenu(GetMenu(Me.hwnd), 0))
      
     'clean up
      Erase fontArray()
   
   End If
   
End Sub


Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

   If Button = vbRightButton Then
      PopupMenu zmnuFonts
   End If
   
End Sub
 Comments
 

 
 

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