|
'***************************************************************
'* 本类模块是一个菜单类, 提供了各种样式的菜单的制作方案
'*
'* 版权: 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，它将完成复杂地“画”菜单的任务以及处理各种菜单事件。
DrawEdge .hdc, itemRect, EDGE_ETCHED, BF_TOP
Case Else ' 其它
hPen = CreatePen(SepStyle, 0, SepColor)
hBrush = CreateSolidBrush(BkColor)
SelectObject .hdc, hPen
SelectObject .hdc, hBrush
Rectangle .hdc, itemRect.Left, itemRect.Top, itemRect.Right, itemRect.Bottom
DeleteObject hPen
DeleteObject hBrush
End Select
End If
Else
If Not CBool(MyItemInfo(.itemID).itemState And MIS_DISABLED) Then
' 当菜单项可用时
If .itemState And ODS_SELECTED Then ' 当鼠标移动到菜单项时
' 设置菜单项高亮范围
If SelectScope And ISS_ICON_TEXT Then
itemRect.Left = iconRect.Left
ElseIf SelectScope And ISS_TEXT Then
itemRect.Left = textRect.Left - 2
Else
itemRect.Left = .rcItem.Left
End If
' 处理菜单项无图标或为CHECKBOX时的情况
If (MyItemInfo(.itemID).itemType = MIT_CHECKBOX Or MyItemInfo(.itemID).itemIcon = 0) And SelectScope <> ISS_LEFTBAR_ICON_TEXT Then
itemRect.Left = iconRect.Left
End If
' 画菜单项边框
Select Case EdgeStyle
Case ISES_NONE ' 无边框
Case ISES_SUNKEN ' 凹进
DrawEdge .hdc, itemRect, BDR_SUNKENOUTER, BF_RECT
Case ISES_RAISED ' 凸起
DrawEdge .hdc, itemRect, BDR_RAISEDINNER, BF_RECT
Case Else ' 其它
hPen = CreatePen(EdgeStyle, 0, EdgeColor)
hBrush = CreateSolidBrush(BkColor)
SelectObject .hdc, hPen
SelectObject .hdc, hBrush
Rectangle .hdc, itemRect.Left, itemRect.Top, itemRect.Right, itemRect.Bottom
DeleteObject hPen
DeleteObject hBrush
End Select
' 画菜单项背景
InflateRect itemRect, -1, -1
Select Case FillStyle
Case ISFS_NONE ' 无背景
Case ISFS_HORIZONTALCOLOR ' 水平渐变色
BlueArea = Int(FillEndColor / &H10000) - Int(FillStartColor / &H10000)
GreenArea = (Int(FillEndColor / &H100) And &HFF) - (Int(FillStartColor / &H100) And &HFF)
RedArea = (FillEndColor And &HFF) - (FillStartColor And &HFF)
For i = itemRect.Left To itemRect.Right - 1
red = Int(FillStartColor And &HFF) + Int((i - itemRect.Left) / (itemRect.Right - itemRect.Left + 1) * RedArea)
green = (Int(FillStartColor / &H100) And &HFF) + Int((i - itemRect.Left) / (itemRect.Right - itemRect.Left + 1) * GreenArea)
blue = Int(FillStartColor / &H10000) + Int((i - itemRect.Left) / (itemRect.Right - itemRect.Left + 1) * BlueArea)
hPen = CreatePen(PS_SOLID, 1, RGB(red, green, blue))
Call SelectObject(.hdc, hPen)
Call MoveToEx(.hdc, i, itemRect.Top, 0)
Call LineTo(.hdc, i, itemRect.Bottom)
Call DeleteObject(hPen)
Next i
Case ISFS_VERTICALCOLOR ' 垂直渐变色
BlueArea = Int(FillEndColor / &H10000) - Int(FillStartColor / &H10000)
GreenArea = (Int(FillEndColor / &H100) And &HFF) - (Int(FillStartColor / &H100) And &HFF)
RedArea = (FillEndColor And &HFF) - (FillStartColor And &HFF)
For i = itemRect.Top To itemRect.Bottom - 1
red = Int(FillStartColor And &HFF) + Int((i - itemRect.Top) / (itemRect.Bottom - itemRect.Top + 1) * RedArea)
green = (Int(FillStartColor / &H100) And &HFF) + Int((i - itemRect.Top) / (itemRect.Bottom - itemRect.Top + 1) * GreenArea)
blue = Int(FillStartColor / &H10000) + Int((i - itemRect.Top) / (itemRect.Bottom - itemRect.Top + 1) * BlueArea)
hPen = CreatePen(PS_SOLID, 1, RGB(red, green, blue))
Call SelectObject(.hdc, hPen)
Call MoveToEx(.hdc, itemRect.Left, i, 0)
Call LineTo(.hdc, itemRect.Right, i)
Call DeleteObject(hPen)
Next i
Case ISFS_SOLIDCOLOR ' 实色填充
hPen = CreatePen(PS_SOLID, 0, FillStartColor)
hBrush = CreateSolidBrush(FillStartColor)
SelectObject .hdc, hPen
SelectObject .hdc, hBrush
Rectangle .hdc, itemRect.Left, itemRect.Top, itemRect.Right, itemRect.Bottom
DeleteObject hPen
DeleteObject hBrush
End Select
' 画菜单项文字
SetTextColor .hdc, TextSelectColor
DrawText .hdc, MyItemInfo(.itemID).itemText, -1, textRect, DT_SINGLELINE Or DT_LEFT Or DT_VCENTER
' 画菜单项图标
If MyItemInfo(.itemID).itemType <> MIT_CHECKBOX Then
DrawIconEx .hdc, iconRect.Left + 2, iconRect.Top + (iconRect.Bottom - iconRect.Top + 1 - 16) / 2, MyItemInfo(.itemID).itemIcon, 16, 16, 0, 0, DI_NORMAL
Select Case IconStyle
Case IIS_NONE ' 无效果
Case IIS_SUNKEN ' 凹进
If MyItemInfo(.itemID).itemIcon <> 0 Then
DrawEdge .hdc, iconRect, BDR_SUNKENOUTER, BF_RECT
End If
Case IIS_RAISED ' 凸起
If MyItemInfo(.itemID).itemIcon <> 0 Then
DrawEdge .hdc, iconRect, BDR_RAISEDINNER, BF_RECT
End If
Case IIS_SHADOW ' 阴影
hBrush = CreateSolidBrush(RGB(128, 128, 128))
DrawState .hdc, hBrush, 0, MyItemInfo(.itemID).itemIcon, 0, iconRect.Left + 3, iconRect.Top + (iconRect.Bottom - iconRect.Top + 1 - 16) / 2 + 1, 0, 0, DST_ICON Or DSS_MONO
DeleteObject hBrush
DrawIconEx .hdc, iconRect.Left + 1, iconRect.Top + (iconRect.Bottom - iconRect.Top + 1 - 16) / 2 - 1, MyItemInfo(.itemID).itemIcon, 16, 16, 0, 0, DI_NORMAL
End Select
Else
' CHECKBOX型菜单项图标效果
If MyItemInfo(.itemID).itemState And MIS_CHECKED Then
DrawIconEx .hdc, iconRect.Left + 2, iconRect.Top + (iconRect.Bottom - iconRect.Top + 1 - 16) / 2, MyItemInfo(.itemID).itemIcon, 16, 16, 0, 0, DI_NORMAL
End If
End If
Else ' 当鼠标移开菜单项时
' 画菜单项边框和背景(清除)
If BarStyle <> LBS_NONE Then
itemRect.Left = barRect.Right + 1
Else
itemRect.Left = 0
End If
hBrush = CreateSolidBrush(BkColor)
FillRect .hdc, itemRect, hBrush
DeleteObject hBrush
' 画菜单项文字
SetTextColor .hdc, TextEnabledColor
DrawText .hdc, MyItemInfo(.itemID).itemText, -1, textRect, DT_SINGLELINE Or DT_LEFT Or DT_VCENTER
' 画菜单项图标
If MyItemInfo(.itemID).itemType <> MIT_CHECKBOX Then
DrawIconEx .hdc, iconRect.Left + 2, iconRect.Top + (iconRect.Bottom - iconRect.Top + 1 - 16) / 2, MyItemInfo(.itemID).itemIcon, 16, 16, 0, 0, DI_NORMAL
Else
If MyItemInfo(.itemID).itemState And MIS_CHECKED Then
DrawIconEx .hdc, iconRect.Left + 2, iconRect.Top + (iconRect.Bottom - iconRect.Top + 1 - 16) / 2, MyItemInfo(.itemID).itemIcon, 16, 16, 0, 0, DI_NORMAL
End If
End If
End If
Else ' 当菜单项不可用时
' 画菜单项文字
SetTextColor .hdc, TextDisabledColor
DrawText .hdc, MyItemInfo(.itemID).itemText, -1, textRect, DT_SINGLELINE Or DT_LEFT Or DT_VCENTER
' 画菜单项图标
If MyItemInfo(.itemID).itemType <> MIT_CHECKBOX Then
DrawState .hdc, 0, 0, MyItemInfo(.itemID).itemIcon, 0, iconRect.Left + 2, iconRect.Top + (iconRect.Bottom - iconRect.Top + 1 - 16) / 2, 0, 0, DST_ICON Or DSS_DISABLED
Else
If MyItemInfo(.itemID).itemState And MIS_CHECKED Then
DrawState .hdc, 0, 0, MyItemInfo(.itemID).itemIcon, 0, iconRect.Left + 2, iconRect.Top + (iconRect.Bottom - iconRect.Top + 1 - 16) / 2, 0, 0, DST_ICON Or DSS_DISABLED
End If
End If
End If
End If
End With
End If
End Sub
' 菜单项事件响应(单击菜单项)
Private Sub MenuItemSelected(ByVal itemID As Long)
Debug.Print "鼠标单击了：" & MyItemInfo(itemID).itemText
Select Case MyItemInfo(itemID).itemAlias
Case "exit"
Dim frm As Form
For Each frm In Forms
Unload frm
Next
End Select
End Sub
' 菜单项事件响应(选择菜单项)
Private Sub MenuItemSelecting(ByVal itemID As Long)
Debug.Print "鼠标移动到：" & MyItemInfo(itemID).itemText
End Sub
到此为止，我们就完成了菜单类的编写，且还包括一个测试窗体。现在，完整的工程里应该包括两个窗体：frmMain和frmMenu；一个标准模块：mMenu；一个类模块：cMenu。按F5编译运行一下，在窗体空白处单击鼠标右键。怎么样，出现弹出式菜单了吗？换个风格再试试。
看完这篇文章后，我想你应该已经对采用物主绘图技术的自绘菜单有了一定的了解，再看看MS Office 2003的菜单，其实也没什么难的嘛。
本文程序在Windows XP、vb6下调试通过。
|
