mmenu.bas

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

Public Const BF_DIAGONAL_ENDBOTTOMLEFT = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT)
Public Const BF_DIAGONAL_ENDBOTTOMRIGHT = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT)

' nPenStyle to CreatePen
Public Const PS_DASH = 1                            ' 画笔类型:虚线 (nWidth必须是1)         -------
Public Const PS_DASHDOT = 3                         ' 画笔类型:点划线 (nWidth必须是1)       _._._._
Public Const PS_DASHDOTDOT = 4                      ' 画笔类型:点-点-划线 (nWidth必须是1)   _.._.._
Public Const PS_DOT = 2                             ' 画笔类型:点线 (nWidth必须是1)         .......
Public Const PS_SOLID = 0                           ' 画笔类型:实线                         _______


' -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- API 类型声明 -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Type DRAWITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemAction As Long
    itemState As Long
    hwndItem As Long
    hdc As Long
    rcItem As RECT
    itemData As Long
End Type

Public Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type

Public Type MEASUREITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemWidth As Long
    itemHeight As Long
    itemData As Long
End Type

Public Type Size
    cx As Long
    cy As Long
End Type


' 自定义菜单项数据结构
Public Type MyMenuItemInfo
    itemIcon As StdPicture
    itemAlias As String
    itemText As String
    itemType As MenuItemType
    itemState As MenuItemState
End Type

' 菜单相关结构
Private MeasureInfo As MEASUREITEMSTRUCT
Private DrawInfo As DRAWITEMSTRUCT

Public hMenu As Long
Public preMenuWndProc As Long
Public MyItemInfo() As MyMenuItemInfo

' 菜单类属性
Public BarWidth As Long                             ' 菜单附加条宽度
Public BarStyle As MenuLeftBarStyle                 ' 菜单附加条风格
Public BarImage As StdPicture                       ' 菜单附加条图像
Public BarStartColor As Long                        ' 菜单附加条过渡色起始颜色
Public BarEndColor As Long                          ' 菜单附加条过渡色终止颜色
Public SelectScope As MenuItemSelectScope           ' 菜单项高亮条的范围
Public TextEnabledColor As Long                     ' 菜单项可用时文字颜色
Public TextDisabledColor As Long                    ' 菜单项不可用时文字颜色
Public TextSelectColor As Long                      ' 菜单项选中时文字颜色
Public IconStyle As MenuItemIconStyle               ' 菜单项图标风格
Public EdgeStyle As MenuItemSelectEdgeStyle         ' 菜单项边框风格
Public EdgeColor As Long                            ' 菜单项边框颜色
Public FillStyle As MenuItemSelectFillStyle         ' 菜单项背景填充风格
Public FillStartColor As Long                       ' 菜单项过渡色起始颜色
Public FillEndColor As Long                         ' 菜单项过渡色终止颜色
Public BkColor As Long                              ' 菜单背景颜色
Public SepStyle As MenuSeparatorStyle               ' 菜单分隔条风格
Public SepColor As Long                             ' 菜单分隔条颜色
Public MenuStyle As MenuUserStyle                   ' 菜单总体风格

' 拦截菜单消息 (frmMenu 窗口入口函数)
Function MenuWndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case Msg
        Case WM_COMMAND                                                 ' 单击菜单项
            If MyItemInfo(wParam).itemType = MIT_CHECKBOX Then
                If MyItemInfo(wParam).itemState = MIS_CHECKED Then
                    MyItemInfo(wParam).itemState = MIS_UNCHECKED
                Else
                    MyItemInfo(wParam).itemState = MIS_CHECKED
                End If
            End If
            MenuItemSelected wParam
        Case WM_EXITMENULOOP                                            ' 退出菜单消息循环(保留)
            
        Case WM_MEASUREITEM                                             ' 处理菜单项高度和宽度
            MeasureItem hwnd, lParam
        Case WM_MENUSELECT                                              ' 选择菜单项
            Dim itemID As Long
            itemID = GetMenuItemID(lParam, wParam And &HFF)
            If itemID <> -1 Then
                MenuItemSelecting itemID
            End If
        Case WM_DRAWITEM                                                ' 绘制菜单项
            DrawItem lParam
    End Select
    MenuWndProc = CallWindowProc(preMenuWndProc, hwnd, Msg, wParam, lParam)
End Function

' 处理菜单高度和宽度
Private Sub MeasureItem(ByVal hwnd As Long, ByVal lParam As Long)
    Dim TextSize As Size, hdc As Long
    hdc = GetDC(hwnd)
    CopyMemory MeasureInfo, ByVal lParam, Len(MeasureInfo)
    If MeasureInfo.CtlType And ODT_MENU Then
        MeasureInfo.itemWidth = lstrlen(MyItemInfo(MeasureInfo.itemID).itemText) * (GetSystemMetrics(SM_CYMENU) / 2.5) + BarWidth
        If MyItemInfo(MeasureInfo.itemID).itemType <> MIT_SEPARATOR Then
            MeasureInfo.itemHeight = GetSystemMetrics(SM_CYMENU)
        Else
            MeasureInfo.itemHeight = 6
        End If
    End If
    CopyMemory ByVal lParam, MeasureInfo, Len(MeasureInfo)
    ReleaseDC hwnd, hdc
End Sub

' 绘制菜单项
Private Sub DrawItem(ByVal lParam As Long)
    Dim hPen As Long, hBrush As Long
    Dim itemRect As RECT, barRect As RECT, iconRect As RECT, textRect As RECT
    Dim i As Long
    CopyMemory DrawInfo, ByVal lParam, Len(DrawInfo)
    If DrawInfo.CtlType = ODT_MENU Then
        SetBkMode DrawInfo.hdc, TRANSPARENT
        
        ' 初始化菜单项矩形, 图标矩形, 文字矩形
        itemRect = DrawInfo.rcItem
        iconRect = DrawInfo.rcItem
        textRect = DrawInfo.rcItem
        
        ' 设置菜单附加条矩形
        With barRect
            .Left = 0
            .Top = 0
            .Right = BarWidth - 1
            For i = 0 To GetMenuItemCount(hMenu) - 1
                If MyItemInfo(i).itemType = MIT_SEPARATOR Then
                    .Bottom = .Bottom + 6
                Else
                    .Bottom = .Bottom + MeasureInfo.itemHeight
                End If
            Next i
            .Bottom = .Bottom - 1
        End With
        
        ' 设置图标矩形, 文字矩形
        If BarStyle <> LBS_NONE Then iconRect.Left = barRect.Right + 2
        iconRect.Right = iconRect.Left + 20
        textRect.Left = iconRect.Right + 3
        
        With DrawInfo
        
            ' 画菜单背景
            itemRect.Left = barRect.Right
            hBrush = CreateSolidBrush(BkColor)
            FillRect .hdc, itemRect, hBrush
            DeleteObject hBrush

        
            ' 画菜单左边的附加条
            Dim RedArea As Long, GreenArea As Long, BlueArea As Long
            Dim red As Long, green As Long, blue As Long
            Select Case BarStyle
                Case LBS_NONE                                           ' 无附加条

                Case LBS_SOLIDCOLOR                                     ' 实色填充

                    hBrush = CreateSolidBrush(BarStartColor)
                    FillRect .hdc, barRect, hBrush
                    DeleteObject hBrush

                Case LBS_HORIZONTALCOLOR                                ' 水平过渡色

                    BlueArea = Int(BarEndColor / &H10000) - Int(BarStartColor / &H10000)
                    GreenArea = (Int(BarEndColor / &H100) And &HFF) - (Int(BarStartColor / &H100) And &HFF)
                    RedArea = (BarEndColor And &HFF) - (BarStartColor And &HFF)

                    For i = 0 To BarWidth - 1
                        red = Int(BarStartColor And &HFF) + Int(i / BarWidth * RedArea)
                        green = (Int(BarStartColor / &H100) And &HFF) + Int(i / BarWidth * GreenArea)
                        blue = Int(BarStartColor / &H10000) + Int(i / BarWidth * BlueArea)
                        hPen = CreatePen(PS_SOLID, 1, RGB(red, green, blue))
                        Call SelectObject(.hdc, hPen)
                        Call MoveToEx(.hdc, i, 0, 0)
                        Call LineTo(.hdc, i, barRect.Bottom)
                        Call DeleteObject(hPen)
                    Next i

                Case LBS_VERTICALCOLOR                                  ' 垂直过渡色

                    BlueArea = Int(BarEndColor / &H10000) - Int(BarStartColor / &H10000)
                    GreenArea = (Int(BarEndColor / &H100) And &HFF) - (Int(BarStartColor / &H100) And &HFF)
                    RedArea = (BarEndColor And &HFF) - (BarStartColor And &HFF)

                    For i = 0 To barRect.Bottom
                        red = Int(BarStartColor And &HFF) + Int(i / (barRect.Bottom + 1) * RedArea)
                        green = (Int(BarStartColor / &H100) And &HFF) + Int(i / (barRect.Bottom + 1) * GreenArea)
                        blue = Int(BarStartColor / &H10000) + Int(i / (barRect.Bottom + 1) * BlueArea)
                        hPen = CreatePen(PS_SOLID, 1, RGB(red, green, blue))
                        Call SelectObject(.hdc, hPen)
                        Call MoveToEx(.hdc, 0, i, 0)
                        Call LineTo(.hdc, barRect.Right, i)