cmenu.cls

多功能菜单、弹出菜单设计、个性化菜单

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'**************************************************************************************************************
'* 本类模块是一个菜单类, 提供了各种样式的菜单的制作方案
'*
'* 版权: 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