浏览器

开发平台：
Visual Basic

PopMenu.cls：源码内容
							VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cPopMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'cPopMenu,用api生成的 popup menu
'2004-12-18 修正了UnCheckAll的一个错误
'2004-12-17 修改了popup,popup2函数,增加了enum pmnTPM
'2004-11-29 增加函数GetItemCount
'2004-11-28 补充了两种状态 pmsUnChecked pmsPopup,修正了pmsDisabled
'           增加了函数:RemoveItems
'           增加一参数:NODestroy,可以设置退出时是否destroy menu
'2004-9-13  发现当使用CheckRadioItem后,UnCheckAll无效,已修正
'2004-8-11  添加一个函数 Add2,可以指定添加的菜单项的位置
'2004-6-26  添加了几个函数DeleteItem,ClearItems,CheckItem,
'    CheckRadioItem,UnCheckAll
'1:14 2004-3-5
Option Explicit
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetMenuDefaultItem Lib "user32" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPos As Long) As Long
Private Declare Function EnableMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
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
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function InsertMenu Lib "user32" Alias "InsertMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function CheckMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDCheckItem As Long, ByVal wCheck As Long) As Long
Private Declare Function CheckMenuRadioItem Lib "user32" (ByVal hMenu As Long, ByVal un1 As Long, ByVal un2 As Long, ByVal un3 As Long, ByVal un4 As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Public Enum pmnTPM
    TPM_BOTTOMALIGN = &H20&
    TPM_CENTERALIGN = &H4&
    TPM_HORIZONTAL = &H0&
    TPM_HORNEGANIMATION = &H800&
    TPM_HORPOSANIMATION = &H400&
    TPM_LEFTALIGN = &H0&
    TPM_LEFTBUTTON = &H0&
    TPM_NOANIMATION = &H4000&
    TPM_NONOTIFY = &H80&
    TPM_RECURSE = &H1&
    TPM_RETURNCMD = &H100&
    TPM_RIGHTALIGN = &H8&
    TPM_RIGHTBUTTON = &H2&
    TPM_TOPALIGN = &H0&
    TPM_VCENTERALIGN = &H10&
    TPM_VERNEGANIMATION = &H2000&
    TPM_VERPOSANIMATION = &H1000&
    TPM_VERTICAL = &H40&
    
    TPM_Default = TPM_LEFTALIGN Or TPM_RETURNCMD
End Enum
Private Const MF_BYCOMMAND = &H0&         '菜单条目由菜单的命令ID指定
Private Const MF_BYPOSITION = &H400&      '菜单条目由条目在菜单中的位置决定。零代表菜单中的第一个条目
Private Const MF_CHECKED = &H8&           '检查指定的菜单条目。不能与VB的Checked属性兼容
Private Const MF_DISABLED = &H2&          '禁止指定的菜单条目。不与VB的Enabled属性兼容
Private Const MF_ENABLED = &H0&           '允许指定的菜单条目。不与VB的Enabled属性兼容
Private Const MF_GRAYED = &H1&            '禁止指定的菜单条目，并用浅灰色描述它。不与VB的Enabled属性兼容
Private Const MF_HILITE = &H80&
Private Const MF_SEPARATOR = &H800&       '在指定的条目处显示一条分隔线
Private Const MF_STRING = &H0&            '在指定的条目处放置一个字串。不与VB的Caption属性兼容
Private Const MF_UNCHECKED = &H0&         '检查指定的条目。不能与VB的Checked属性兼容
Private Const MF_UNHILITE = &H0&
Private Const MF_POPUP = &H10&            '将一个弹出式菜单置于指定的条目。可用于创建子菜单及弹出式菜单
Private Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Boolean, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
Private Const MIIM_FTYPE As Long = &H100
Private Const MIIM_STATE As Long = &H1
Private Const MFT_RADIOCHECK As Long = &H200&
Private Const MFS_CHECKED As Long = MF_CHECKED
Private Const MFS_UNCHECKED = MF_UNCHECKED
Private Type POINTAPI
    x As Long
    y As Long
End Type
Public Enum enumPopMenuMenuStyle
    pmsString = MF_STRING
    pmsSeparator = MF_SEPARATOR
    pmsChecked = MF_CHECKED
    pmsUnChecked = MF_UNCHECKED
    pmsDisabled = MF_DISABLED Or MF_GRAYED
    pmsHilite = MF_HILITE
    pmsPopup = MF_POPUP
End Enum
'local variable(s) to hold property value(s)
Private mvarhwnd As Long 'local copy
Private mvarParent As Long
'退出时不毁灭 menu
Public NODestroy As Boolean
Public Function Popup(Optional AutoPos As Boolean = True, _
        Optional x As Long, Optional y As Long, _
        Optional ByVal nFlag As pmnTPM = TPM_Default) As Long
Dim rtn As Long
rtn = Popup2(mvarParent, AutoPos, x, y, nFlag)
Popup = rtn
End Function
Public Function Popup2(nParent As Long, Optional AutoPos As Boolean = True, _
        Optional x As Long, Optional y As Long, _
        Optional ByVal nFlag As pmnTPM = TPM_Default) As Long
Dim tpt As POINTAPI
Dim rtn As Long
If AutoPos Then
    Call GetCursorPos(tpt)
Else
    tpt.x = x
    tpt.y = y
End If
'nFlag = TPM_LEFTALIGN Or TPM_RECURSE Or TPM_RETURNCMD
rtn = TrackPopupMenu(hwnd, nFlag, tpt.x, tpt.y, 0&, nParent, 0&)
Debug.Print rtn
Popup2 = rtn
End Function
'在菜单末尾添加
Public Sub Add(nCaption As String, _
    Optional nFlag As enumPopMenuMenuStyle = pmsString, _
    Optional id As Long, Optional DefaultItem As Boolean = False)
If mvarhwnd <> 0 Then
    Call AppendMenu(mvarhwnd, nFlag, id, nCaption)
    If DefaultItem Then
        Call SetMenuDefaultItem(mvarhwnd, id, 0)
    End If
End If
End Sub
'可以添加在任何位置
Public Sub Add2(nCaption As String, _
    uItem As Long, Optional fByPosition As Boolean = True, _
    Optional nFlag As enumPopMenuMenuStyle = pmsString, _
    Optional id As Long)
If mvarhwnd <> 0 Then
    If fByPosition Then
        nFlag = nFlag Or MF_BYPOSITION
    Else
        nFlag = nFlag Or MF_BYCOMMAND
    End If
    
    Call InsertMenu(mvarhwnd, uItem, nFlag, id, nCaption)
End If
End Sub
Public Property Get hwnd() As Long
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.hwnd
    hwnd = mvarhwnd
End Property
'获得菜单项的数量
Public Function GetItemCount() As Long
If mvarhwnd <> 0 Then
    GetItemCount = GetMenuItemCount(mvarhwnd)
End If
End Function
Public Function SetDefault(nID As Long, Optional ByCommand As Boolean = True) As Boolean
Dim rtn As Boolean
rtn = False
If mvarhwnd <> 0 Then
    If SetMenuDefaultItem(mvarhwnd, nID, Not ByCommand) <> 0 Then rtn = True
End If
SetDefault = rtn
End Function
Public Function EnableItem(uID As Long, nEnable As Boolean, Optional ByCommand As Boolean = True)
Dim nFlag As Long
If nEnable Then
    nFlag = MF_ENABLED
Else
    nFlag = MF_DISABLED Or MF_GRAYED
End If
If ByCommand Then
    nFlag = nFlag Or MF_BYCOMMAND
Else
    nFlag = nFlag Or MF_BYPOSITION
End If
Call EnableMenuItem(mvarhwnd, uID, nFlag)
End Function
'check某item(勾)
Public Function CheckItem(uID As Long, nChecked As Boolean, Optional ByCommand As Boolean = True)
Dim nFlag As Long
If mvarhwnd <> 0 Then
    If nChecked Then
        nFlag = MF_CHECKED
    Else
        nFlag = MF_UNCHECKED
    End If
    
    If ByCommand Then
        nFlag = nFlag Or MF_BYCOMMAND
    Else
        nFlag = nFlag Or MF_BYPOSITION
    End If
    
    Call CheckMenuItem(mvarhwnd, uID, nFlag)
End If
End Function
Public Function UnCheckAll()
Dim i&
Dim tcnt&
Dim tIIf As MENUITEMINFO
If mvarhwnd <> 0 Then
    tcnt = GetMenuItemCount(mvarhwnd)
    With tIIf
        .cbSize = Len(tIIf)
        .fMask = MIIM_FTYPE Or MIIM_STATE
    End With
    
    For i = 0 To tcnt - 1
        GetMenuItemInfo mvarhwnd, i, True, tIIf
        tIIf.fState = tIIf.fState Or MFS_CHECKED Xor MFS_CHECKED
        tIIf.fType = tIIf.fType Or MFT_RADIOCHECK Xor MFT_RADIOCHECK
        Call SetMenuItemInfo(mvarhwnd, i, True, tIIf)
    Next i
End If
'Dim i&
'Dim tFlag&, tCnt&
'If mvarhwnd <> 0 Then
'    tCnt = GetMenuItemCount(mvarhwnd)
'    tFlag = MF_UNCHECKED Or MF_BYPOSITION
'    For i = 0 To tCnt - 1
'        Call CheckMenuItem(mvarhwnd, i, tFlag)
'    Next i
'End If
End Function
'check某item,其他un check(圆)
Public Function CheckRadioItem(uID As Long, Optional ByCommand As Boolean = True)
Dim tcnt&
Dim tFlag&
If mvarhwnd <> 0 Then
    If ByCommand Then
        tFlag = MF_BYCOMMAND
    Else
        tFlag = MF_BYPOSITION
    End If
    
    tcnt = GetMenuItemCount(mvarhwnd)
    Call CheckMenuRadioItem(mvarhwnd, 0, tcnt - 1, uID, tFlag)
End If
End Function
'删除某项, 会 destroy sub menu
Public Function DeleteItem(uID As Long, Optional ByCommand As Boolean = True)
Dim tFlag As Long
If mvarhwnd <> 0 Then
    If ByCommand Then
        tFlag = MF_BYCOMMAND
    Else
        tFlag = MF_BYPOSITION
    End If
    
    Call DeleteMenu(mvarhwnd, uID, tFlag)
End If
End Function
'删除多项,index from uPos1 to uPos2,不会 destroy sub menu
Public Function RemoveItems(uPos1&, uPos2&)
Dim i&
If mvarhwnd <> 0 Then
    If uPos1 <= uPos2 Then
        For i = uPos2 To uPos1 Step -1
            Call RemoveMenu(mvarhwnd, i, MF_BYPOSITION)
        Next i
    End If
End If
End Function
'删除全部项
Public Function ClearItems()
Dim i&, tcnt&
If mvarhwnd <> 0 Then
    tcnt = GetMenuItemCount(mvarhwnd)
    For i = tcnt - 1 To 0 Step -1
        Call DeleteMenu(mvarhwnd, i, MF_BYPOSITION)
    Next i
End If
End Function
Public Function Create(Optional nHwdPopMenu As Long = 0) As Boolean
If mvarhwnd <> 0 Then Call Destroy
If nHwdPopMenu = 0 Then
    mvarhwnd = CreatePopupMenu
    If mvarhwnd <> 0 Then
        Create = True
    Else
        Create = False
    End If
Else
    mvarhwnd = nHwdPopMenu
    Create = True
End If
End Function
Public Function Destroy() As Boolean
If mvarhwnd <> 0 Then
    Call DestroyMenu(mvarhwnd)
    mvarhwnd = 0
End If
End Function
Private Sub Class_Initialize()
mvarhwnd = 0
NODestroy = False
End Sub
Private Sub Class_Terminate()
If NODestroy Then
Else
    Call Destroy
End If
End Sub
Public Property Get Parent() As Long
    Parent = mvarParent
End Property
Public Property Let Parent(ByVal vNewValue As Long)
    mvarParent = vNewValue
End Property

						