用VB打造“超酷”个性化菜单

下面我们来创建接收消息的窗体：打开上面建好的工程，添加一个窗体，并将其名称设置为frmMenu（注意：这一步是必须的）。图5菜单左边那个黑底色的附加条，为了方便，将frmMenu的Picture属性设置成图5。到此，这个窗体就算OK了！对了，就这样，因为这个窗体仅仅是为了处理消息和存储那个黑底色的风格条，我们将会对它进行子类处理，处理消息的代码全部都放在了将在下面详细介绍的标准模块中。

　　接下来添加一个类模块，并将其名称设置为cMenu，代码如下：

'*************************************************************** '* 本类模块是一个菜单类, 提供了各种样式的菜单的制作方案 '* '* 版权: LPP软件工作室 '* 作者: 卢培培(goodname008) '* (******* 复制请保留以上信息 *******) '********************************************************************* Option Explicit Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As Any) As Long Public Enum MenuUserStyle ' 菜单总体风格 　STYLE_WINDOWS 　STYLE_XP 　STYLE_SHADE 　STYLE_3D 　STYLE_COLORFUL End Enum Public Enum MenuSeparatorStyle ' 菜单分隔条风格 　MSS_SOLID 　MSS_DASH 　MSS_DOT 　MSS_DASDOT 　MSS_DASHDOTDOT 　MSS_NONE 　MSS_DEFAULT End Enum Public Enum MenuItemSelectFillStyle ' 菜单项背景填充风格 　ISFS_NONE 　ISFS_SOLIDCOLOR 　ISFS_HORIZONTALCOLOR 　ISFS_VERTICALCOLOR End Enum Public Enum MenuItemSelectEdgeStyle ' 菜单项边框风格 　ISES_SOLID 　ISES_DASH 　ISES_DOT 　ISES_DASDOT 　ISES_DASHDOTDOT 　ISES_NONE 　ISES_SUNKEN 　ISES_RAISED End Enum Public Enum MenuItemIconStyle ' 菜单项图标风格 　IIS_NONE 　IIS_SUNKEN 　IIS_RAISED 　IIS_SHADOW End Enum Public Enum MenuItemSelectScope ' 菜单项高亮条的范围 　ISS_TEXT = &H1 　ISS_ICON_TEXT = &H2 　ISS_LEFTBAR_ICON_TEXT = &H4 End Enum Public Enum MenuLeftBarStyle ' 菜单附加条风格 　LBS_NONE 　LBS_SOLIDCOLOR 　LBS_HORIZONTALCOLOR 　LBS_VERTICALCOLOR 　LBS_IMAGE End Enum Public Enum MenuItemType ' 菜单项类型 　MIT_STRING = &H0 　MIT_CHECKBOX = &H200 　MIT_SEPARATOR = &H800 End Enum Public Enum MenuItemState ' 菜单项状态 　MIS_ENABLED = &H0 　MIS_DISABLED = &H2 　MIS_CHECKED = &H8 　MIS_UNCHECKED = &H0 End Enum Public Enum PopupAlign ' 菜单弹出对齐方式 　POPUP_LEFTALIGN = &H0& ' 水平左对齐 　POPUP_CENTERALIGN = &H4& ' 水平居中对齐 　POPUP_RIGHTALIGN = &H8& ' 水平右对齐 　POPUP_TOPALIGN = &H0& ' 垂直上对齐 　POPUP_VCENTERALIGN = &H10& ' 垂直居中对齐 　POPUP_BOTTOMALIGN = &H20& ' 垂直下对齐 End Enum ' 释放类 Private Sub Class_Terminate() 　SetWindowLong frmMenu.hwnd, GWL_WNDPROC, preMenuWndProc 　Erase MyItemInfo 　DestroyMenu hMenu End Sub ' 创建弹出式菜单 Public Sub CreateMenu() 　preMenuWndProc = SetWindowLong(frmMenu.hwnd, GWL_WNDPROC, AddressOf MenuWndProc) 　hMenu = CreatePopupMenu() 　Me.Style = STYLE_WINDOWS End Sub ' 插入菜单项并保存自定义菜单项数组, 设置Owner_Draw自绘菜单 Public Sub AddItem(ByVal itemAlias As String, ByVal itemIcon As StdPicture, 　　ByVal itemText As String, ByVal itemType As MenuItemType, 　　Optional ByVal itemState As MenuItemState) 　Static ID As Long, i As Long 　Dim ItemInfo As MENUITEMINFO 　' 插入菜单项 　With ItemInfo 　　.cbSize = LenB(ItemInfo) 　　.fMask = MIIM_STRING Or MIIM_FTYPE Or MIIM_STATE Or MIIM_SUBMENU Or MIIM_ID Or MIIM_DATA 　　.fType = itemType 　　.fState = itemState 　　.wID = ID 　　.dwItemData = True 　　.cch = lstrlen(itemText) 　　.dwTypeData = itemText 　End With 　InsertMenuItem hMenu, ID, False, ItemInfo 　' 将菜单项数据存入动态数组 　ReDim Preserve MyItemInfo(ID) As MyMenuItemInfo 　For i = 0 To UBound(MyItemInfo) 　　If MyItemInfo(i).itemAlias = itemAlias Then 　　　Class_Terminate 　　　Err.Raise vbObjectError + 513, "cMenu", "菜单项别名相同." 　　End If 　Next i 　With MyItemInfo(ID) 　　Set .itemIcon = itemIcon 　　.itemText = itemText 　　.itemType = itemType 　　.itemState = itemState 　　.itemAlias = itemAlias 　End With 　' 获得菜单项数据 　With ItemInfo 　　.cbSize = LenB(ItemInfo) 　　.fMask = MIIM_DATA Or MIIM_ID Or MIIM_TYPE 　End With 　GetMenuItemInfo hMenu, ID, False, ItemInfo 　' 设置菜单项数据 　With ItemInfo 　　.fMask = .fMask Or MIIM_TYPE 　　.fType = MFT_OWNERDRAW 　End With 　SetMenuItemInfo hMenu, ID, False, ItemInfo 　' 菜单项ID累加 　ID = ID + 1 End Sub ' 删除菜单项 Public Sub DeleteItem(ByVal itemAlias As String) 　Dim i As Long 　For i = 0 To UBound(MyItemInfo) 　　If MyItemInfo(i).itemAlias = itemAlias Then 　　　DeleteMenu hMenu, i, 0 　　　Exit For 　　End If 　Next i End Sub ' 弹出菜单 Public Sub PopupMenu(ByVal x As Long, ByVal y As Long, ByVal Align As PopupAlign) 　TrackPopupMenu hMenu, Align, x, y, 0, frmMenu.hwnd, ByVal 0 End Sub ' 设置菜单项图标 Public Sub SetItemIcon(ByVal itemAlias As String, ByVal itemIcon As StdPicture) 　Dim i As Long 　For i = 0 To UBound(MyItemInfo) 　　If MyItemInfo(i).itemAlias = itemAlias Then 　　　Set MyItemInfo(i).itemIcon = itemIcon 　　　Exit For 　　End If 　Next i End Sub ' 获得菜单项图标 Public Function GetItemIcon(ByVal itemAlias As String) As StdPicture 　Dim i As Long 　For i = 0 To UBound(MyItemInfo) 　　If MyItemInfo(i).itemAlias = itemAlias Then 　　　Set GetItemIcon = MyItemInfo(i).itemIcon 　　　Exit For 　　End If 　Next i End Function ' 设置菜单项文字 Public Sub SetItemText(ByVal itemAlias As String, ByVal itemText As String) 　Dim i As Long 　For i = 0 To UBound(MyItemInfo) 　　If MyItemInfo(i).itemAlias = itemAlias Then 　　　MyItemInfo(i).itemText = itemText 　　　Exit For 　　End If 　Next i End Sub ' 获得菜单项文字 Public Function GetItemText(ByVal itemAlias As String) As String 　Dim i As Long 　For i = 0 To UBound(MyItemInfo) 　　If MyItemInfo(i).itemAlias = itemAlias Then 　　　GetItemText = MyItemInfo(i).itemText 　　　Exit For 　　End If 　Next i End Function ' 设置菜单项状态 Public Sub SetItemState(ByVal itemAlias As String, ByVal itemState As MenuItemState) 　Dim i As Long 　For i = 0 To UBound(MyItemInfo) 　　If MyItemInfo(i).itemAlias = itemAlias Then 　　　MyItemInfo(i).itemState = itemState 　　　Dim ItemInfo As MENUITEMINFO 　　　With ItemInfo 　　　　.cbSize = Len(ItemInfo) 　　　　.fMask = MIIM_STRING Or MIIM_FTYPE Or MIIM_STATE Or MIIM_SUBMENU Or MIIM_ID Or MIIM_DATA 　　　End With 　　　GetMenuItemInfo hMenu, i, False, ItemInfo 　　　With ItemInfo 　　　　.fState = .fState Or itemState 　　　End With 　　　SetMenuItemInfo hMenu, i, False, ItemInfo 　　　Exit For 　　End If 　Next i End Sub ' 获得菜单项状态 Public Function GetItemState(ByVal itemAlias As String) As MenuItemState 　Dim i As Long 　For i = 0 To UBound(MyItemInfo) 　　If MyItemInfo(i).itemAlias = itemAlias Then 　　　GetItemState = MyItemInfo(i).itemState 　　　Exit For 　　End If 　Next i End Function ' 属性: 菜单句柄 Public Property Get hwnd() As Long 　hwnd = hMenu End Property Public Property Let hwnd(ByVal nValue As Long) End Property ' 属性: 菜单附加条宽度 Public Property Get LeftBarWidth() As Long 　LeftBarWidth = BarWidth End Property Public Property Let LeftBarWidth(ByVal nBarWidth As Long) 　If nBarWidth >= 0 Then 　　BarWidth = nBarWidth 　End If End Property ' 属性: 菜单附加条风格 Public Property Get LeftBarStyle() As MenuLeftBarStyle 　LeftBarStyle = BarStyle End Property Public Property Let LeftBarStyle(ByVal nBarStyle As MenuLeftBarStyle) 　If nBarStyle >= 0 And nBarStyle <= 4 Then 　　BarStyle = nBarStyle 　End If End Property ' 属性: 菜单附加条图像(只有当 LeftBarStyle 设置为 LBS_IMAGE 时才有效) Public Property Get LeftBarImage() As StdPicture 　Set LeftBarImage = BarImage End Property Public Property Let LeftBarImage(ByVal nBarImage As StdPicture) 　Set BarImage = nBarImage End Property ' 属性: 菜单附加条过渡色起始颜色( '只有当 LeftBarStyle 设置为 LBS_HORIZONTALCOLOR 或 LBS_VERTICALCOLOR 时才有效) ' 当 LeftBarStyle 设置为 LBS_SOLIDCOLOR (实色填充)时以 LeftBarStartColor 颜色为准 Public Property Get LeftBarStartColor() As Long 　LeftBarStartColor = BarStartColor End Property Public Property Let LeftBarStartColor(ByVal nBarStartColor As Long) 　BarStartColor = nBarStartColor End Property ' 属性: 菜单附加条过渡色终止颜色( '只有当 LeftBarStyle 设置为 LBS_HORIZONTALCOLOR 或 LBS_VERTICALCOLOR 时才有效) ' 当 LeftBarStyle 设置为 LBS_SOLIDCOLOR (实色填充)时以 LeftBarStartColor 颜色为准 Public Property Get LeftBarEndColor() As Long 　LeftBarEndColor = BarEndColor End Property Public Property Let LeftBarEndColor(ByVal nBarEndColor As Long) 　BarEndColor = nBarEndColor End Property ' 属性: 菜单项高亮条的范围 Public Property Get ItemSelectScope() As MenuItemSelectScope 　ItemSelectScope = SelectScope End Property Public Property Let ItemSelectScope(ByVal nSelectScope As MenuItemSelectScope) 　SelectScope = nSelectScope End Property ' 属性: 菜单项可用时文字颜色 Public Property Get ItemTextEnabledColor() As Long 　ItemTextEnabledColor = TextEnabledColor End Property Public Property Let ItemTextEnabledColor(ByVal nTextEnabledColor As Long) 　TextEnabledColor = nTextEnabledColor End Property ' 属性: 菜单项不可用时文字颜色 Public Property Get ItemTextDisabledColor() As Long 　ItemTextDisabledColor = TextDisabledColor End Property Public Property Let ItemTextDisabledColor(ByVal nTextDisabledColor As Long) 　TextDisabledColor = nTextDisabledColor End Property ' 属性: 菜单项选中时文字颜色 Public Property Get ItemTextSelectColor() As Long 　ItemTextSelectColor = TextSelectColor End Property Public Property Let ItemTextSelectColor(ByVal nTextSelectColor As Long) 　TextSelectColor = nTextSelectColor End Property ' 属性: 菜单项图标风格 Public Property Get ItemIconStyle() As MenuItemIconStyle 　ItemIconStyle = IconStyle End Property Public Property Let ItemIconStyle(ByVal nIconStyle As MenuItemIconStyle) 　IconStyle = nIconStyle End Property ' 属性: 菜单项边框风格 Public Property Get ItemSelectEdgeStyle() As MenuItemSelectEdgeStyle 　ItemSelectEdgeStyle = EdgeStyle End Property Public Property Let ItemSelectEdgeStyle(ByVal nEdgeStyle As MenuItemSelectEdgeStyle) 　EdgeStyle = nEdgeStyle End Property ' 属性: 菜单项边框颜色 Public Property Get ItemSelectEdgeColor() As Long 　ItemSelectEdgeColor = EdgeColor End Property Public Property Let ItemSelectEdgeColor(ByVal nEdgeColor As Long) 　EdgeColor = nEdgeColor End Property ' 属性: 菜单项背景填充风格 Public Property Get ItemSelectFillStyle() As MenuItemSelectFillStyle 　ItemSelectFillStyle = FillStyle End Property Public Property Let ItemSelectFillStyle(ByVal nFillStyle As MenuItemSelectFillStyle) 　FillStyle = nFillStyle End Property ' 属性: 菜单项过渡色起始颜色( '只有当 ItemSelectFillStyle 设置为 ISFS_HORIZONTALCOLOR 或 ISFS_VERTICALCOLOR 时才有效) ' 当 ItemSelectFillStyle 设置为 ISFS_SOLIDCOLOR (实色填充)时以 'ItemSelectFillStartColor 颜色为准 Public Property Get ItemSelectFillStartColor() As Long 　ItemSelectFillStartColor = FillStartColor End Property Public Property Let ItemSelectFillStartColor(ByVal nFillStartColor As Long) 　FillStartColor = nFillStartColor End Property ' 属性: 菜单项过渡色终止颜色( '只有当 ItemSelectFillStyle 设置为 ISFS_HORIZONTALCOLOR 或 ISFS_VERTICALCOLOR 时才有效) ' 当 ItemSelectFillStyle 设置为 ISFS_SOLIDCOLOR (实色填充)时以 'ItemSelectFillStartColor 颜色为准 Public Property Get ItemSelectFillEndColor() As Long 　ItemSelectFillEndColor = FillEndColor End Property Public Property Let ItemSelectFillEndColor(ByVal nFillEndColor As Long) 　FillEndColor = nFillEndColor End Property ' 属性: 菜单背景颜色 Public Property Get BackColor() As Long 　BackColor = BkColor End Property Public Property Let BackColor(ByVal nBkColor As Long) 　BkColor = nBkColor End Property ' 属性: 菜单分隔条风格 Public Property Get SeparatorStyle() As MenuSeparatorStyle 　SeparatorStyle = SepStyle End Property Public Property Let SeparatorStyle(ByVal nSepStyle As MenuSeparatorStyle) 　SepStyle = nSepStyle End Property ' 属性: 菜单分隔条颜色 Public Property Get SeparatorColor() As Long 　SeparatorColor = SepColor End Property Public Property Let SeparatorColor(ByVal nSepColor As Long) 　SepColor = nSepColor End Property ' 属性: 菜单总体风格 Public Property Get Style() As MenuUserStyle 　Style = MenuStyle End Property Public Property Let Style(ByVal nMenuStyle As MenuUserStyle) 　MenuStyle = nMenuStyle 　Select Case nMenuStyle 　　Case STYLE_WINDOWS ' Windows 默认风格 　　　Set BarImage = LoadPicture() 　　　BarWidth = 20 　　　BarStyle = LBS_NONE 　　　BarStartColor = GetSysColor(COLOR_MENU) 　　　BarEndColor = BarStartColor 　　　SelectScope = ISS_ICON_TEXT 　　　TextEnabledColor = GetSysColor(COLOR_MENUTEXT) 　　　TextDisabledColor = GetSysColor(COLOR_GRAYTEXT) 　　　TextSelectColor = GetSysColor(COLOR_HIGHLIGHTTEXT) 　　　IconStyle = IIS_NONE 　　　EdgeStyle = ISES_SOLID 　　　EdgeColor = GetSysColor(COLOR_HIGHLIGHT) 　　　FillStyle = ISFS_SOLIDCOLOR 　　　FillStartColor = EdgeColor 　　　FillEndColor = FillStartColor 　　　BkColor = GetSysColor(COLOR_MENU) 　　　SepColor = TextDisabledColor 　　　SepStyle = MSS_DEFAULT 　　Case STYLE_XP ' XP 风格 　　　Set BarImage = LoadPicture() 　　　BarWidth = 20 　　　BarStyle = LBS_NONE 　　　BarStartColor = GetSysColor(COLOR_MENU) 　　　BarEndColor = BarStartColor 　　　SelectScope = ISS_ICON_TEXT 　　　TextEnabledColor = GetSysColor(COLOR_MENUTEXT) 　　　TextDisabledColor = GetSysColor(COLOR_GRAYTEXT) 　　　TextSelectColor = TextEnabledColor 　　　IconStyle = IIS_SHADOW 　　　EdgeStyle = ISES_SOLID 　　　EdgeColor = RGB(49, 106, 197) 　　　FillStyle = ISFS_SOLIDCOLOR 　　　FillStartColor = RGB(180, 195, 210) 　　　FillEndColor = FillStartColor 　　　BkColor = GetSysColor(COLOR_MENU) 　　　SepColor = RGB(192, 192, 192) 　　　SepStyle = MSS_SOLID 　　Case STYLE_SHADE ' 渐变风格 　　　Set BarImage = LoadPicture() 　　　BarWidth = 20 　　　BarStyle = LBS_VERTICALCOLOR 　　　BarStartColor = vbBlack 　　　BarEndColor = vbWhite 　　　SelectScope = ISS_ICON_TEXT 　　　TextEnabledColor = GetSysColor(COLOR_MENUTEXT) 　　　TextDisabledColor = GetSysColor(COLOR_GRAYTEXT) 　　　TextSelectColor = GetSysColor(COLOR_HIGHLIGHTTEXT) 　　　IconStyle = IIS_NONE 　　　EdgeStyle = ISES_NONE 　　　EdgeColor = GetSysColor(COLOR_HIGHLIGHT) 　　　FillStyle = ISFS_HORIZONTALCOLOR 　　　FillStartColor = vbBlack 　　　FillEndColor = vbWhite 　　　BkColor = GetSysColor(COLOR_MENU) 　　　SepColor = TextDisabledColor 　　　SepStyle = MSS_DEFAULT 　　Case STYLE_3D ' 3D 立体风格 　　　Set BarImage = LoadPicture() 　　　BarWidth = 20 　　　BarStyle = LBS_NONE 　　　BarStartColor = GetSysColor(COLOR_MENU) 　　　BarEndColor = BarStartColor 　　　SelectScope = ISS_TEXT 　　　TextEnabledColor = GetSysColor(COLOR_MENUTEXT) 　　　TextDisabledColor = GetSysColor(COLOR_GRAYTEXT) 　　　TextSelectColor = vbBlue 　　　IconStyle = IIS_RAISED 　　　EdgeStyle = ISES_SUNKEN 　　　EdgeColor = GetSysColor(COLOR_HIGHLIGHT) 　　　FillStyle = ISFS_NONE 　　　FillStartColor = EdgeColor 　　　FillEndColor = FillStartColor 　　　BkColor = GetSysColor(COLOR_MENU) 　　　SepColor = TextDisabledColor 　　　SepStyle = MSS_DEFAULT 　　Case STYLE_COLORFUL ' 炫彩风格 　　　Set BarImage = frmMenu.Picture 　　　BarWidth = 20 　　　BarStyle = LBS_IMAGE 　　　BarStartColor = GetSysColor(COLOR_MENU) 　　　BarEndColor = BarStartColor 　　　SelectScope = ISS_ICON_TEXT 　　　TextEnabledColor = vbBlue 　　　TextDisabledColor = RGB(49, 106, 197) 　　　TextSelectColor = vbRed 　　　IconStyle = IIS_NONE 　　　EdgeStyle = ISES_DOT 　　　EdgeColor = vbBlack 　　　FillStyle = ISFS_VERTICALCOLOR 　　　FillStartColor = vbYellow 　　　FillEndColor = vbGreen 　　　BkColor = RGB(230, 230, 255) 　　　SepColor = vbMagenta 　　　SepStyle = MSS_DASHDOTDOT 　　End Select End Property

　　这个类模块中包含了各种属性和方法及关于菜单的一些枚举类型，我想强调的有以下几点：

　　1、在CreateMenu方法中用SetWindowLong重新定义了frmMenu的窗口入口函数的地址，MenuWndProc是标准模块中的一个函数，就是处理消息的那个函数。
　
　　2、AddItem这个方法是添加菜单项的，使用一个叫做MyItemInfo的动态数组存储菜单项的内容，在“画”菜单项的时候要用到它。在AddItem方法的最后，将菜单项的fType设置成了MFT_OWNERDRAW，也就是物主绘图，这一步最关键，因为将菜单项设置成了Owner Draw，Windows将不会替我们写字，不会替我们画图标，一切都由我们自己来。

　　3、在PopupMenu方法中，调用了API函数中的TrackPopupMenu，看到第6个参数了吗？将处理菜单消息的窗口设置成了frmMenu，而我们又对frmMenu进行了子类处理，一切都在我们的掌握之中。

　　4、记得要在Class_Terminate中还原frmMenu的窗口入口函数的地址，并释放和菜单相关的资源。

　　好了，类模块已经OK了，大家可能对这个菜单类有了更多的了解，也看到了它的属性和方法。怎么样？还算比较丰富吧。如果觉得不够丰富的话，自己加就好了，呵呵。不过，最核心的部分还不在这里，而是在那个处理消息的函数，也就是MenuWndProc，它将完成复杂地“画”菜单的任务以及处理各种菜单事件。