VB打造超酷个性化菜单

• 菜单
• 个性化
• 超酷
• 打造
• EndProperty
• 属性
• Ge

     下面我们来创建接收消息的窗体：打开上次建好的工程，添加一个窗体，并将其名称设置为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                         ' 菜单项边框风格#p#分页标题#e#
    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&                               ' 垂直下对齐#p#分页标题#e#
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)#p#分页标题#e#
        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#p#分页标题#e#
            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#p#分页标题#e#
    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#p#分页标题#e#
    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)#p#分页标题#e#
            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)#p#分页标题#e#
            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，它将完成复杂地“画”菜单的任务以及处理各种菜单#p#分页标题#e#事件。看看右边的滚动条，已经够窄了，下一篇再讨论吧。 :)