|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
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 |
|
|
|
|||||
|
|||||
|
|||||
Copyright ©1996-2011 VBnet and Randy Birch. All Rights Reserved. |