浏览器

开发平台：
Visual Basic

cODMenus.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 = "cODMenus"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'----------------------------------------------------
'cODMenus
'自画菜单总处理
'2005-3-14  可以拥有多个 cImageList,使用中方便删除
'----------------------------------------------------
'8/5/2005   :修改了 RstMenu中的    TempCSM.Text.. 赋值
Option Explicit
Private mCSMenuCols As Collection
Private Const m_def_key$ = "def"
'Public SMenus As New CCSMenu '菜单集合
'Public IcoImgList As  ImageList '菜单图标的ImageList
Private mIcoImgList As cImageList  '菜单图标的ImageList
Private mIconImgListZZ As Collection    '菜单图标的ImageList集合
'整体添加图标
Public Sub IniImageList(vBmp&, cx&, cy&, Optional vKey As String = m_def_key)
Set mIcoImgList = GetImgLstObj2(vKey, False)     ' New cImageList
mIcoImgList.LoadImageList_Object vBmp, cx, cy
End Sub
Public Function GetImgLstObj(Optional vKey$ = m_def_key) As cImageList
On Error Resume Next
Set GetImgLstObj = Nothing
Set GetImgLstObj = mIconImgListZZ(vKey)
End Function
Public Function GetImgLstObj2(Optional vKey$ = m_def_key, Optional vCreateDef As Boolean = True) As cImageList
Dim rtn As cImageList
Set rtn = GetImgLstObj(vKey)
If rtn Is Nothing Then
    Set rtn = New cImageList
    If vCreateDef Then
        rtn.Create 16, 16
    End If
    mIconImgListZZ.Add rtn, vKey
End If
Set GetImgLstObj2 = rtn
End Function
Public Function RemoveImgLstObj(vKey$) As Boolean
On Error Resume Next
Err.Clear
mIconImgListZZ.Remove vKey
RemoveImgLstObj = (Err.Number = 0)
End Function
'Public Function GetImgLstObj() As cImageList
'Set GetImgLstObj = mIcoImgList
'End Function
Public Sub On_WM_MEASUREITEM(ByVal lParam&)
Dim TempMIS As MEASUREITEMSTRUCT
Dim tCanExit As Boolean
Dim tCol As CCSMenu ' Collection
Dim pSM As ClsSMenu
CopyMemory TempMIS, ByVal lParam, Len(TempMIS)
tCanExit = False
For Each tCol In mCSMenuCols
    If tCol.hMenu = TempMIS.itemData Then
        For Each pSM In tCol
            If pSM.MeID = TempMIS.itemID Then
                pSM.SetSize lParam
                tCanExit = True
                Exit For
            End If
        Next pSM
    End If
    If tCanExit Then Exit For
Next tCol
End Sub
Public Sub On_WM_DRAWITEM(ByVal lParam&)
Dim TempDIS As DRAWITEMSTRUCT
Dim tCanExit As Boolean
Dim tCol As CCSMenu  ' Collection
Dim pSM As ClsSMenu
CopyMemory TempDIS, ByVal lParam, Len(TempDIS)
tCanExit = False
For Each tCol In mCSMenuCols
    If tCol.hMenu = TempDIS.hwndItem Then
        For Each pSM In tCol
            If pSM.MeID = TempDIS.itemID Then
                pSM.MeDraw lParam
                tCanExit = True
                Exit For
            End If
        Next pSM
    End If
    If tCanExit Then Exit For
Next tCol
End Sub
'注册菜单
Public Function RstMenu(MenuUpID As Long, MenuID As Long, _
    Optional Key As String, _
    Optional ByVal IcoIndex As Variant, _
    Optional ByVal IcoSelIndex As Variant = -1, _
    Optional ByVal IcoDisIndex As Variant = -1, _
    Optional ByPosition As Long = 1, _
    Optional Tag$, Optional vILstKey$ = m_def_key _
    ) As ClsSMenu
    
    
    Dim TempCSM As ClsSMenu
    Dim TempMII As MENUITEMINFO
    Dim StrByt(0 To 256) As Byte
    
    With TempMII
        .cbSize = Len(TempMII) '结构大小为44字节
        .fMask = MIIM_ID Or MIIM_STATE Or MIIM_TYPE Or MIIM_DATA '要取得的数据项目
        .dwTypeData = VarPtr(StrByt(0)) '菜单文字存储地址
        .cch = UBound(StrByt) '菜单文字长度
    End With
    
    '如果返回0（不成功）则退出
    If GetMenuItemInfo(MenuUpID, MenuID, ByPosition, TempMII) = 0 Then Exit Function
    'Set TempCSM = SMenus.Add(key)  '添加项目
'    Set TempCSM = New ClsSMenu
'    GetCols(colKey).Add TempCSM ',    Key
    Set TempCSM = GetCols(MenuUpID).Add(Key)
    TempCSM.Tag = Tag
    Set TempCSM.IconList = GetImgLstObj2(vILstKey) ' mIcoImgList
    
'    TempCSM.IcoIndex = IcoImgList.ListImages(IcoIndex).index  '给图标索引赋值
'    If IcoSelIndex < 0 Then
'        TempCSM.IcoSelIndex = TempCSM.IcoIndex ' IcoIndex
'    Else
'        TempCSM.IcoSelIndex = IcoImgList.ListImages(IcoSelIndex).index
'    End If
'    If IcoDisIndex < 0 Then
'        TempCSM.IcoDisableIndex = TempCSM.IcoIndex 'IcoIndex
'    Else
'        TempCSM.IcoDisableIndex = IcoImgList.ListImages(IcoDisIndex).index
'    End If
    TempCSM.IcoIndex = IcoIndex  '给图标索引赋值
    If IcoSelIndex < 0 Then
        TempCSM.IcoSelIndex = TempCSM.IcoIndex ' IcoIndex
    Else
        TempCSM.IcoSelIndex = IcoSelIndex
    End If
    If IcoDisIndex < 0 Then
        TempCSM.IcoDisableIndex = TempCSM.IcoIndex 'IcoIndex
    Else
        TempCSM.IcoDisableIndex = IcoDisIndex
    End If
    
    
    
    TempCSM.MeUpID = MenuUpID '菜单上级句柄
    TempCSM.MeID = TempMII.wID '菜单句柄
    'TempCSM.Text = StrConv(LeftB(StrByt, TempMII.cch), vbUnicode) '菜单文字
    TempCSM.Text = LeftB(StrByt, TempMII.cch) '菜单文字
    If TempMII.fState And MFS_CHECKED Then TempCSM.Check = True 'Check属性
    If TempMII.fState And MFT_RADIOCHECK Then TempCSM.Radio = True 'Radio属性
    If TempMII.fState And (MFS_DISABLED Or MFS_GRAYED) Then TempCSM.Enabled = False 'Enabled属性
    
    With TempMII
        .cbSize = Len(TempMII) '结构大小为44字节
        .fMask = MIIM_TYPE Or MIIM_DATA  '要改变的数据项目
        .dwTypeData = VarPtr(StrByt(0)) '菜单文字存储地址
        .fType = .fType Or MFT_OWNERDRAW '改为 自画 属性
        .dwItemData = MenuUpID
    End With
    Call SetMenuItemInfo(MenuUpID, MenuID, ByPosition, TempMII)     '设置菜单
    
    Set RstMenu = TempCSM '返回值
    Set TempCSM = Nothing
    
End Function
'Private Function GetCols(Key$) As Collection
'On Error Resume Next
'Dim rtn As Collection
'If Key = "" Then
'    Key = m_def_key
'End If
'
'    Err.Clear
'    Set rtn = mCSMenuCols(Key)
'    If Err.Number <> 0 Then
'        Set rtn = New Collection
'        mCSMenuCols.Add rtn, Key
'    End If
'
'Set GetCols = rtn
'End Function
Private Function GetCols(vHmnu&) As CCSMenu
Dim rtn As CCSMenu
For Each rtn In mCSMenuCols
    If rtn.hMenu = vHmnu Then
        Exit For
    End If
Next rtn
If rtn Is Nothing Then
    Set rtn = New CCSMenu
    rtn.hMenu = vHmnu
    mCSMenuCols.Add rtn
Else
    If rtn.hMenu <> vHmnu Then
        Set rtn = New CCSMenu
        rtn.hMenu = vHmnu
        mCSMenuCols.Add rtn
    End If
End If
    
Set GetCols = rtn
End Function
'移除相同tag的菜单
Public Sub RemoveMulODMenu(vTag As String)
Dim tCol As CCSMenu
Dim tODm As ClsSMenu
Dim tcnt&, i&
For Each tCol In mCSMenuCols
    tcnt = tCol.Count
    For i = tcnt To 1 Step -1
        Set tODm = tCol(i)
        If tODm.Tag = vTag Then
            tCol.Remove i
        End If
    Next i
Next tCol
End Sub
'移除同一菜单下的项目
Public Sub RemoveCol(vHmnu&) '(Key$)
On Error Resume Next
Dim tCol As CCSMenu
Dim tcnt&, i&
tcnt = mCSMenuCols.Count
For i = 1 To tcnt
    Set tCol = mCSMenuCols(i)
    If tCol.hMenu = vHmnu Then
        Call mCSMenuCols.Remove(i)
        Exit For
    End If
Next i
'mCSMenuCols.Remove Key
End Sub
Private Sub Class_Initialize()
Set mCSMenuCols = New Collection
Set mIconImgListZZ = New Collection
End Sub
Private Sub Class_Terminate()
Set mCSMenuCols = Nothing
Set mIconImgListZZ = Nothing
End Sub

						