编程技术 [分享]VB打造超酷个性化菜单||做专业的GIS技术交流论坛

首页>GIS开发和数据库技术>编程技术>[分享]VB打造超酷个性化菜单

« 返回列表

« 上一页 1 2

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

加关注写私信

10楼^#

发布于：2004-11-04 11:19

' 设置菜单项状态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 iEnd 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 iEnd Function ' 属性: 菜单句柄Public Property Get hwnd() As Long hwnd = hMenuEnd Property Public Property Let hwnd(ByVal nValue As Long) End Property ' 属性: 菜单附加条宽度Public Property Get LeftBarWidth() As Long LeftBarWidth = BarWidthEnd Property Public Property Let LeftBarWidth(ByVal nBarWidth As Long) If nBarWidth >= 0 Then BarWidth = nBarWidth End IfEnd Property ' 属性: 菜单附加条风格Public Property Get LeftBarStyle() As MenuLeftBarStyle LeftBarStyle = BarStyleEnd Property Public Property Let LeftBarStyle(ByVal nBarStyle As MenuLeftBarStyle) If nBarStyle >= 0 And nBarStyle <= 4 Then BarStyle = nBarStyle End IfEnd Property ' 属性: 菜单附加条图像(只有当 LeftBarStyle 设置为 LBS_IMAGE 时才有效)Public Property Get LeftBarImage() As StdPicture Set LeftBarImage = BarImageEnd Property Public Property Let LeftBarImage(ByVal nBarImage As StdPicture) Set BarImage = nBarImageEnd Property ' 属性: 菜单附加条过渡色起始颜色(只有当 LeftBarStyle 设置为 LBS_HORIZONTALCOLOR 或 LBS_VERTICALCOLOR 时才有效)' 当 LeftBarStyle 设置为 LBS_SOLIDCOLOR (实色填充)时以 LeftBarStartColor 颜色为准Public Property Get LeftBarStartColor() As Long LeftBarStartColor = BarStartColorEnd Property Public Property Let LeftBarStartColor(ByVal nBarStartColor As Long) BarStartColor = nBarStartColorEnd Property ' 属性: 菜单附加条过渡色终止颜色(只有当 LeftBarStyle 设置为 LBS_HORIZONTALCOLOR 或 LBS_VERTICALCOLOR 时才有效)' 当 LeftBarStyle 设置为 LBS_SOLIDCOLOR (实色填充)时以 LeftBarStartColor 颜色为准Public Property Get LeftBarEndColor() As Long LeftBarEndColor = BarEndColorEnd Property Public Property Let LeftBarEndColor(ByVal nBarEndColor As Long) BarEndColor = nBarEndColorEnd Property ' 属性: 菜单项高亮条的范围Public Property Get ItemSelectScope() As MenuItemSelectScope ItemSelectScope = SelectScopeEnd Property Public Property Let ItemSelectScope(ByVal nSelectScope As MenuItemSelectScope) SelectScope = nSelectScopeEnd Property ' 属性: 菜单项可用时文字颜色Public Property Get ItemTextEnabledColor() As Long ItemTextEnabledColor = TextEnabledColorEnd Property Public Property Let ItemTextEnabledColor(ByVal nTextEnabledColor As Long) TextEnabledColor = nTextEnabledColorEnd Property ' 属性: 菜单项不可用时文字颜色Public Property Get ItemTextDisabledColor() As Long ItemTextDisabledColor = TextDisabledColorEnd Property Public Property Let ItemTextDisabledColor(ByVal nTextDisabledColor As Long) TextDisabledColor = nTextDisabledColorEnd Property ' 属性: 菜单项选中时文字颜色Public Property Get ItemTextSelectColor() As Long ItemTextSelectColor = TextSelectColorEnd Property Public Property Let ItemTextSelectColor(ByVal nTextSelectColor As Long) TextSelectColor = nTextSelectColorEnd Property ' 属性: 菜单项图标风格Public Property Get ItemIconStyle() As MenuItemIconStyle ItemIconStyle = IconStyleEnd Property Public Property Let ItemIconStyle(ByVal nIconStyle As MenuItemIconStyle) IconStyle = nIconStyleEnd Property ' 属性: 菜单项边框风格Public Property Get ItemSelectEdgeStyle() As MenuItemSelectEdgeStyle ItemSelectEdgeStyle = EdgeStyleEnd Property Public Property Let ItemSelectEdgeStyle(ByVal nEdgeStyle As MenuItemSelectEdgeStyle) EdgeStyle = nEdgeStyleEnd Property ' 属性: 菜单项边框颜色Public Property Get ItemSelectEdgeColor() As Long ItemSelectEdgeColor = EdgeColorEnd Property Public Property Let ItemSelectEdgeColor(ByVal nEdgeColor As Long) EdgeColor = nEdgeColorEnd Property ' 属性: 菜单项背景填充风格Public Property Get ItemSelectFillStyle() As MenuItemSelectFillStyle ItemSelectFillStyle = FillStyleEnd Property Public Property Let ItemSelectFillStyle(ByVal nFillStyle As MenuItemSelectFillStyle) FillStyle = nFillStyleEnd Property ' 属性: 菜单项过渡色起始颜色(只有当 ItemSelectFillStyle 设置为 ISFS_HORIZONTALCOLOR 或 ISFS_VERTICALCOLOR 时才有效)' 当 ItemSelectFillStyle 设置为 ISFS_SOLIDCOLOR (实色填充)时以 ItemSelectFillStartColor 颜色为准Public Property Get ItemSelectFillStartColor() As Long ItemSelectFillStartColor = FillStartColorEnd Property Public Property Let ItemSelectFillStartColor(ByVal nFillStartColor As Long) FillStartColor = nFillStartColorEnd Property ' 属性: 菜单项过渡色终止颜色(只有当 ItemSelectFillStyle 设置为 ISFS_HORIZONTALCOLOR 或 ISFS_VERTICALCOLOR 时才有效)' 当 ItemSelectFillStyle 设置为 ISFS_SOLIDCOLOR (实色填充)时以 ItemSelectFillStartColor 颜色为准Public Property Get ItemSelectFillEndColor() As Long ItemSelectFillEndColor = FillEndColorEnd Property Public Property Let ItemSelectFillEndColor(ByVal nFillEndColor As Long) FillEndColor = nFillEndColorEnd Property ' 属性: 菜单背景颜色Public Property Get BackColor() As Long BackColor = BkColorEnd Property Public Property Let BackColor(ByVal nBkColor As Long) BkColor = nBkColorEnd Property ' 属性: 菜单分隔条风格Public Property Get SeparatorStyle() As MenuSeparatorStyle SeparatorStyle = SepStyleEnd Property Public Property Let SeparatorStyle(ByVal nSepStyle As MenuSeparatorStyle) SepStyle = nSepStyleEnd Property ' 属性: 菜单分隔条颜色Public Property Get SeparatorColor() As Long SeparatorColor = SepColorEnd Property Public Property Let SeparatorColor(ByVal nSepColor As Long) SepColor = nSepColorEnd Property

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

加关注写私信

11楼^#

发布于：2004-11-04 11:19

其实，漂亮的界面都是“画”出来的，菜单当然也不例外。既然是“画”出来的，就需要有窗体来接收“画”菜单这个消息，后面我们会看到，实际上不仅仅是“画”这个消息，一切关于这个菜单的消息都要有一个窗体来接收。如果你对消息不太了解，可以看看网上其它一些关于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_COLORFULEnd Enum Public Enum MenuSeparatorStyle ' 菜单分隔条风格 MSS_SOLID MSS_DASH MSS_DOT MSS_DASDOT MSS_DASHDOTDOT MSS_NONE MSS_DEFAULTEnd Enum Public Enum MenuItemSelectFillStyle ' 菜单项背景填充风格 ISFS_NONE ISFS_SOLIDCOLOR ISFS_HORIZONTALCOLOR ISFS_VERTICALCOLOREnd Enum Public Enum MenuItemSelectEdgeStyle ' 菜单项边框风格 ISES_SOLID ISES_DASH ISES_DOT ISES_DASDOT ISES_DASHDOTDOT ISES_NONE ISES_SUNKEN ISES_RAISEDEnd Enum Public Enum MenuItemIconStyle ' 菜单项图标风格 IIS_NONE IIS_SUNKEN IIS_RAISED IIS_SHADOWEnd Enum Public Enum MenuItemSelectScope ' 菜单项高亮条的范围 ISS_TEXT = ;H1 ISS_ICON_TEXT = ;H2 ISS_LEFTBAR_ICON_TEXT = ;H4End Enum Public Enum MenuLeftBarStyle ' 菜单附加条风格 LBS_NONE LBS_SOLIDCOLOR LBS_HORIZONTALCOLOR LBS_VERTICALCOLOR LBS_IMAGEEnd Enum Public Enum MenuItemType ' 菜单项类型 MIT_STRING = ;H0 MIT_CHECKBOX = ;H200 MIT_SEPARATOR = ;H800End Enum Public Enum MenuItemState ' 菜单项状态 MIS_ENABLED = ;H0 MIS_DISABLED = ;H2 MIS_CHECKED = ;H8 MIS_UNCHECKED = ;H0End 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 hMenuEnd Sub ' 创建弹出式菜单Public Sub CreateMenu() preMenuWndProc = SetWindowLong(frmMenu.hwnd, GWL_WNDPROC, AddressOf MenuWndProc) hMenu = CreatePopupMenu() Me.Style = STYLE_WINDOWSEnd 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 iEnd 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 0End 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 iEnd 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 iEnd 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 iEnd 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 iEnd Function

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

发帖回复

« 返回列表

« 上一页 1 2

您需要登录后才可以回帖，登录或者注册

返回顶部