VB打造超酷个性化菜单（二）

VB打造超酷个性化菜单（二）

    其实，漂亮的界面都是“画”出来的，菜单当然也不例外。既然是“画”出来的，就需要有窗体来接收“画”菜单这个消息，后面我们会看到，实际上不仅仅是“画”这个消息，一切关于这个菜单的消息都要有一个窗体来接收。如果你对消息不太了解，可以看看网上其它一些关于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是标准模块中的一个函数，就是处理消息的那个函数。frmMenu这个窗体一行代码也没有，只用来将其子类化，在窗口函数中处理菜单消息，同时还利用Picture属性存储了一幅图片，就是多彩风格里菜单左边的那个风格条。

    2、AddItem这个方法是添加菜单项的，使用一个叫做MyItemInfo的动态数组存储菜单项的内容，在“画”菜单项的时候要用到它。在AddItem方法的最后，将菜单项的fType设置成了MFT_OWNERDRAW，也就是物主绘图，这一步最关键，因为将菜单项设置成了Owner Draw，Windows将不会替我们写字，不会替我们画图标，一切都由我们自己来。

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

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

 

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

 

（待续）