VB打造超酷个性化菜单(二)

VB打造超酷个性化菜单(二)

其实,漂亮的界面都是“画”出来的,菜单当然也不例外。既然是“画”出来的,就需要有窗体来接收“画”菜单这个消息,后面我们会看到,实际上不仅仅是“画”这个消息,一切关于这个菜单的消息都要有一个窗体来接收。如果你对消息不太了解,可以看看网上其它一些关于 Windows 消息机制的文章。不了解也没有关系,只要会使用就可以了,后面的文章给出了完整的源代码,而且文章的最后还给出了源代码的下载地址。

下面我们来创建接收消息的窗体:打开上次建好的工程,添加一个窗体,并将其名称设置为 frmMenu ( 注意:这一步是必须的 )。还记得上篇文章的最后一幅图吗?菜单左边那个黑底色的附加条,为了方便,将 frmMenu 的 Picture 属性设置成那幅图。到此,这个窗体就算 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

<span lang="EN" style="FONT-FAMILY: 宋

Published At
Categories with Web编程
Tagged with
comments powered by Disqus