用VB打造“超酷”個性化菜單
眾所周知，MS Office 2003推出已經有一段時間了，但我們依然不會忘記Office XP剛剛推出時其令人耳目一新的菜單給我們留下的深刻印象。突起的懸浮式圖標，不同尋常的菜單項填充方式，不僅讓辦公一族們贊不絕口，更讓廣大的程序員和編程愛好者對這種風格的菜單的制作產生了濃厚的興趣。所以，在這篇文章里，我們就來好好地研究研究用VB怎么制作這種風格的菜單，在文章的最后，我將給出源代碼的下載地址。事實上，在了解其原理以后，不論是用VB、VC還是Delphi，都能夠制作出XP風格的菜單。不僅如此，我們還可以制作出更加充滿個性的另類風格的菜單，比如3D立體風格、漸變風格、多彩風格等等。只有想不到的，沒有做不到的。Follow me！
現在，我想有必要說一說我們現在要做的事情。事實上，我們只要做一個菜單類就行了。但誰都會明白，只做一個菜單類是不夠的，我們需要一個程序，或者更詳細的說，是一個窗體，來測試我們的菜單類。在我個人的開發過程中，我是先寫的菜單類，后寫的測試窗體，但為了讓大家先領略一下寫好的菜單類在應用時是多么的方便，所以讓我們先來看看測試窗體：
（1）打開VB，新建“標準EXE”工程。
（2）--下面是窗體的控件：
其實就是在窗體上添加了一個Frame，然后在Frame里添加OptionButton控件數組，用來設置菜單風格，還有一個Label，上面只顯示一行提示文字，非常簡單。
（3）窗體代碼：
代碼中創建了一個cMenu類的對象，我們的編程重點將會放在cMenu類上，上面的代碼只是簡單地調用cMenu。在后面的文章中，我們會看到其實cMenu有多達30個方法和屬性供我們調用，它的Style屬性只提供了5種內置風格，在實際應用中，我們可以利用cMenu類提供的方法和屬性制作出各種各樣風格的菜單，為自己的程序錦上添花。
（4）運行結果：
圖1
圖2
圖3
圖4
圖5
下面我們來創建接收消息的窗體：打開上面建好的工程，添加一個窗體，并將其名稱設置為frmMenu（注意：這一步是必須的）。圖5菜單左邊那個黑底色的附加條，為了方便，將frmMenu的Picture屬性設置成圖5。到此，這個窗體就算OK了！對了，就這樣，因為這個窗體僅僅是為了處理消息和存儲那個黑底色的風格條，我們將會對它進行子類處理，處理消息的代碼全部都放在了將在下面詳細介紹的標準模塊中。
接下來添加一個類模塊，并將其名稱設置為cMenu，代碼如下：
這個類模塊中包含了各種屬性和方法及關于菜單的一些枚舉類型，我想強調的有以下幾點：
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，它將完成復雜地“畫”菜單的任務以及處理各種菜單事件。
到此為止，我們就完成了菜單類的編寫，且還包括一個測試窗體。現在，完整的工程里應該包括兩個窗體：frmMain和frmMenu；一個標準模塊：mMenu；一個類模塊：cMenu。按F5編譯運行一下，在窗體空白處單擊鼠標右鍵。怎么樣，出現彈出式菜單了嗎？換個風格再試試。
看完這篇文章后，我想你應該已經對采用物主繪圖技術的自繪菜單有了一定的了解，再看看MS Office 2003的菜單，其實也沒什么難的嘛。
本文程序在Windows XP、VB6下調試通過。
現在，我想有必要說一說我們現在要做的事情。事實上，我們只要做一個菜單類就行了。但誰都會明白，只做一個菜單類是不夠的，我們需要一個程序，或者更詳細的說，是一個窗體，來測試我們的菜單類。在我個人的開發過程中，我是先寫的菜單類，后寫的測試窗體，但為了讓大家先領略一下寫好的菜單類在應用時是多么的方便，所以讓我們先來看看測試窗體：
（1）打開VB，新建“標準EXE”工程。
（2）--下面是窗體的控件：
| 組件名稱 | 屬性 | 值 |
| Form | Name | frmMain |
| Caption | 菜單例子 | |
| Frame | Name | fraStyle |
| Caption | 菜單風格 | |
| Label | Name | lblHelp |
| Caption | 在窗體空白處單擊鼠標右鍵 | |
| OptionButton | Name | opnStyle |
| Caption | Window 標準 | |
| Index | 0 | |
| OptionButton | Name | opnStyle |
| Caption | XP 風格 | |
| Index | 1 | |
| OptionButton | Name | opnStyle |
| Caption | 3D 立體風格 | |
| Index | 2 | |
| OptionButton | Name | opnStyle |
| Caption | 漸變風格 | |
| Index | 3 | |
| OptionButton | Name | opnStyle |
| Caption | 多彩風格 | |
| Index | 4 |
其實就是在窗體上添加了一個Frame，然后在Frame里添加OptionButton控件數組，用來設置菜單風格，還有一個Label，上面只顯示一行提示文字，非常簡單。
（3）窗體代碼：
| Option Explicit Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long Private Type POINTAPI X As Long Y As Long End Type Dim menu As cMenu Private Sub Form_Load() ' 初始化菜單并添加菜單項 Set menu = New cMenu menu.CreateMenu menu.AddItem "open", LoadPicture("imagesopen.ico"), "打開", MIT_STRING menu.AddItem "save", LoadPicture("imagessave.ico"), "保存", MIT_STRING menu.AddItem "print", LoadPicture("imagesprint.ico"), "打印", MIT_STRING menu.AddItem "find", LoadPicture("imagesfind.ico"), "查找", MIT_STRING menu.AddItem "sep1", LoadPicture(), "", MIT_SEPARATOR menu.AddItem "undo", LoadPicture("imagesundo.ico"), "撤消", MIT_STRING menu.AddItem "redo", LoadPicture("imagesedo.ico"), "重復", MIT_STRING menu.AddItem "sep2", LoadPicture(), "", MIT_SEPARATOR menu.AddItem "cut", LoadPicture("imagescut.ico"), "剪切", MIT_STRING menu.AddItem "copy", LoadPicture("imagescopy.ico"), "復制", MIT_STRING menu.AddItem "paste", LoadPicture("imagespaste.ico"), "粘貼", MIT_STRING menu.AddItem "sep3", LoadPicture(), "", MIT_SEPARATOR menu.AddItem "check", LoadPicture("imagescheck.ico"), "一個 CheckBox", MIT_CHECKBOX menu.AddItem "exit", LoadPicture("imagesexit.ico"), "退出", MIT_STRING End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ' 單擊鼠標右建彈出菜單 If Button = vbRightButton Then Dim pos As POINTAPI GetCursorPos pos menu.PopupMenu pos.X, pos.Y, POPUP_LEFTALIGN Or POPUP_TOPALIGN End If End Sub Private Sub Form_Unload(Cancel As Integer) ' 釋放資源, 卸載窗體 Set menu = Nothing Dim frm As Form For Each frm In Forms Unload frm Next End Sub Private Sub opnStyle_Click(Index As Integer) ' 設置菜單風格 Select Case Index Case 0 ' Windows 標準 menu.Style = STYLE_WINDOWS Case 1 ' XP 風格 menu.Style = STYLE_XP Case 2 ' 3D 立體風格 menu.Style = STYLE_3D Case 3 ' 漸變風格 menu.Style = STYLE_SHADE Case 4 ' 多彩風格 menu.Style = STYLE_COLORFUL End Select End Sub |
代碼中創建了一個cMenu類的對象，我們的編程重點將會放在cMenu類上，上面的代碼只是簡單地調用cMenu。在后面的文章中，我們會看到其實cMenu有多達30個方法和屬性供我們調用，它的Style屬性只提供了5種內置風格，在實際應用中，我們可以利用cMenu類提供的方法和屬性制作出各種各樣風格的菜單，為自己的程序錦上添花。
（4）運行結果：
圖1
圖2
圖3
圖4
圖5
下面我們來創建接收消息的窗體：打開上面建好的工程，添加一個窗體，并將其名稱設置為frmMenu（注意：這一步是必須的）。圖5菜單左邊那個黑底色的附加條，為了方便，將frmMenu的Picture屬性設置成圖5。到此，這個窗體就算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是標準模塊中的一個函數，就是處理消息的那個函數。
2、AddItem這個方法是添加菜單項的，使用一個叫做MyItemInfo的動態數組存儲菜單項的內容，在“畫”菜單項的時候要用到它。在AddItem方法的最后，將菜單項的fType設置成了MFT_OWNERDRAW，也就是物主繪圖，這一步最關鍵，因為將菜單項設置成了Owner Draw，Windows將不會替我們寫字，不會替我們畫圖標，一切都由我們自己來。
3、在PopupMenu方法中，調用了API函數中的TrackPopupMenu，看到第6個參數了嗎？將處理菜單消息的窗口設置成了frmMenu，而我們又對frmMenu進行了子類處理，一切都在我們的掌握之中。
4、記得要在Class_Terminate中還原frmMenu的窗口入口函數的地址，并釋放和菜單相關的資源。
好了，類模塊已經OK了，大家可能對這個菜單類有了更多的了解，也看到了它的屬性和方法。怎么樣？還算比較豐富吧。如果覺得不夠豐富的話，自己加就好了，呵呵。不過，最核心的部分還不在這里，而是在那個處理消息的函數，也就是MenuWndProc，它將完成復雜地“畫”菜單的任務以及處理各種菜單事件。
| ' 攔截菜單消息 (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)) 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下調試通過。