上一篇:VB打造超酷个性化菜单(1) 其实,漂亮的界面都是“画”出来的,菜单当然也不例外。既然是“画”出来的,就需要有窗体来接收“画”菜单这个消息,后面我们会看到,实际上不仅仅是“画”这个消息,一切关于这个菜单的消息都要有一个窗体来接收。如果你对消息不太了解,可以看看网上其它一些关于Windows消息机制的文章。不了解也没有关系,只要会使用就可以了,后面的文章给出了完整的源代码,而且文章的最后还给出了源代码的下载地址。 下面我们来创建接收消息的窗体:打开上次建好的工程,添加一个窗体,并将其名称设置为frmMenu(注意:这一步是必须的)。还记得上篇文章的最后一幅图吗?菜单左边那个黑底色的附加条,为了方便,将frmMenu的Picture属性设置成那幅图。到此,这个窗体就算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,它将完成复杂地“画”菜单的任务以及处理各种菜单事件。看看右边的滚动条,已经够窄了,下一篇再讨论吧。 :)
|