VB打造超酷个性化菜单（六） （接上篇） ' 拦截菜单消息 (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)
Call DeleteObject(hPen)
Next i Case LBS_IMAGE ' 图像 If BarImage.Handle <> 0 Then
Dim barhDC As Long
barhDC = CreateCompatibleDC(GetDC(0))
SelectObject barhDC, BarImage.Handle
BitBlt .hdc, 0, 0, BarWidth, barRect.Bottom - barRect.Top + 1, barhDC, 0, 0, vbSrcCopy
DeleteDC barhDC
End If End Select
' 画菜单项
If MyItemInfo(.itemID).itemType = MIT_SEPARATOR Then
' 画菜单分隔条(MIT_SEPARATOR)
If MyItemInfo(.itemID).itemType = MIT_SEPARATOR Then
itemRect.Top = itemRect.Top + 2
itemRect.Bottom = itemRect.Top + 1
itemRect.Left = barRect.Right + 5
Select Case SepStyle
Case MSS_NONE ' 无分隔条
Case MSS_DEFAULT ' 默认样式
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))
&nbs p; 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下调试通过。
源代码下载地址：http://y365.com/ses518/soft/samplecsdn.zip（全文完） ***************************************************************** 转载请通知作者并注明出处，谢谢。* 作者：goodname008（卢培培）* 邮箱：goodname008@163.com**************************************************************** 相关链接：
VB打造超酷个性化菜单（一）
VB打造超酷个性化菜单（二）
VB打造超酷个性化菜单（三）
VB打造超酷个性化菜单（四）VB打造超酷个性化菜单（五）VB打造超酷个性化菜单（六） |
