clsmenu.cls

一个clock的 vb 源码

    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    ' 添加菜单项目
    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    Dim lpcMenuItemInfo As MENUITEMINFO
    With lpcMenuItemInfo
        .cbSize = Len(lpcMenuItemInfo)
        .fMask = MIIM_STRING Or MIIM_FTYPE Or MIIM_STATE Or MIIM_SUBMENU Or MIIM_ID
        .fType = fType
        .fState = fState
        .cch = Len(mnuText)
        .dwTypeData = mnuText
        .wID = ID
        If subMenu Then: .hSubMenu = lngSubhMenu
    End With
    InsertMenuItem hMenu, ID, False, lpcMenuItemInfo
End Sub

Public Sub OnCreate()
    'Msdn VC++
    Dim nItem As Long, I As Long, N As Long
    Dim hSubMenu As Long, sItem As Long
    nItem = GetMenuItemCount(hMenu)
    ReDim MnuInfo(18)
    
        For I = 0 To nItem - 1
            Call SetMenuOwnerDraw(hMenu, I)
         
            hSubMenu = GetSubMenu(hMenu, I)
            sItem = GetMenuItemCount(hSubMenu)
           
                If hSubMenu <> 0 And sItem <> -1 Then ' 子菜单
                    For N = 0 To sItem - 1
                        Call SetMenuOwnerDraw(hSubMenu, N)
                    Next
                End If
        Next I
 End Sub

Private Function SetMenuOwnerDraw(lphMenu As Long, uItem As Long)
    Dim lpcMenuItemInfo As MENUITEMINFO
    With lpcMenuItemInfo
        .cbSize = Len(lpcMenuItemInfo)
        .fMask = MIIM_DATA Or MIIM_ID Or MIIM_TYPE
        .dwTypeData = String$(256, 0)
        .cch = Len(.dwTypeData)
    End With
   
    GetMenuItemInfo lphMenu, uItem, True, lpcMenuItemInfo
        
    'Add Menu Type And Menu Text For MnuInfo
    ' Set MFT_OWNERDRAW Type For Menu
    MnuInfo(mnuItemCound).dwTypeData = lpcMenuItemInfo.fType
    MnuInfo(mnuItemCound).szItemText = Left$(lpcMenuItemInfo.dwTypeData, lstrlen(ByVal (lpcMenuItemInfo.dwTypeData)))
    MnuInfo(mnuItemCound).cchItemText = lpcMenuItemInfo.cch

    'Debug.Print lpcMenuItemInfo.cch
    lpcMenuItemInfo.fMask = lpcMenuItemInfo.fMask Or MIIM_TYPE
    lpcMenuItemInfo.fType = MFT_OWNERDRAW
    lpcMenuItemInfo.dwItemData = mnuItemCound
    mnuItemCound = mnuItemCound + 1
    Call SetMenuItemInfo(lphMenu, uItem, True, lpcMenuItemInfo)
End Function

Public Sub OnMeasureItem(hwnd As Long, lParam As Long)
    ' 设置菜单的高度与宽度
    Dim lpmis As MEASUREITEMSTRUCT
    Dim hDc As Long, lpSize As SIZE
    hDc = GetDC(hwnd)
    CopyMemory lpmis, ByVal lParam, Len(lpmis)
        If lpmis.CtlType And ODT_MENU Then
           
            Call GetTextExtentPoint32(hDc, MnuInfo(lpmis.itemData).szItemText, MnuInfo(lpmis.itemData).cchItemText, lpSize)
            lpmis.itemWidth = (lpSize.CX + 19)
                If MnuInfo(lpmis.itemData).dwTypeData <> MFT_SEPARATOR Then
                    lpmis.itemHeight = GetSystemMetrics(SM_CYMENU)
                Else
                    lpmis.itemHeight = 6
                End If
        End If
    CopyMemory ByVal lParam, lpmis, Len(lpmis)
    ReleaseDC hwnd, hDc
End Sub

Public Sub OnDrawItem(lParam As Long)
    
    Dim lpDrawInfo As DRAWITEMSTRUCT
    CopyMemory lpDrawInfo, ByVal lParam, Len(lpDrawInfo)
        
        If lpDrawInfo.CtlType And ODT_MENU Then
            
            SetBkMode lpDrawInfo.hDc, NEWTRANSPARENT
                
                ' 菜单小按钮
                Dim RcButton As RECT
                RcButton = lpDrawInfo.RcItem
                RcButton.Right = 19
                
                ' 减去小按钮剩下的部分
                Dim RcItemBox As RECT
                RcItemBox = lpDrawInfo.RcItem
                RcItemBox.Left = 20
                
                ' 菜单文字
                Dim RcText As RECT
                RcText = lpDrawInfo.RcItem
                RcText.Left = 23
                
                ' 从数组中取菜单文字
                Dim mnuText As String
                Dim mnuTextSize As Long
                Dim bSelected As Boolean
                Dim bMenuButton As Boolean
                Dim bSeparator As Boolean
                
                ' 取菜单文字及文字大小
                mnuText = MnuInfo(lpDrawInfo.itemData).szItemText
                mnuTextSize = MnuInfo(lpDrawInfo.itemData).cchItemText
                
                ' bSelected     菜单是否为选者状态(如果是则画菜单选者时的状态)
                ' bMenuButton   通过判断菜单是否设置了 MFT_MENUBARBREAK 风格来决定是否该有菜单的小按钮
                ' bSeparator    画菜单分隔符
                bSelected = lpDrawInfo.itemState And ODS_SELECTED
                bMenuButton = MnuInfo(lpDrawInfo.itemData).dwTypeData And MFT_MENUBARBREAK
                bSeparator = MnuInfo(lpDrawInfo.itemData).dwTypeData And MFT_SEPARATOR
            
            If bSelected And mnuText <> vbNullString Then
                Call SetTextColor(lpDrawInfo.hDc, GetSysColor(COLOR_HIGHLIGHTTEXT))
                DrawText lpDrawInfo.hDc, mnuText, mnuTextSize, RcText, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
                
                If bMenuButton Then
                    DrawEdge lpDrawInfo.hDc, lpDrawInfo.RcItem, BDR_SUNKENOUTER, BF_RECT
                Else
                    DrawEdge lpDrawInfo.hDc, RcButton, BDR_RAISEDINNER, BF_RECT
                    DrawEdge lpDrawInfo.hDc, RcItemBox, BDR_SUNKENOUTER, BF_RECT
                End If
                'BitBlt lpDrawInfo.hdc,  (lpDrawInfo.RcItem.Left + 1)  , (lpDrawInfo.RcItem.Top + 1), 16, 16, Form1!Picture1.hdc, (lpDrawInfo.itemID * 16), 0, vbSrcCopy
            Else
                Call FillRect(lpDrawInfo.hDc, lpDrawInfo.RcItem, GetSysColorBrush(COLOR_MENU))
                Call SetTextColor(lpDrawInfo.hDc, GetSysColor(COLOR_MENUTEXT))
                Call DrawText(lpDrawInfo.hDc, mnuText, mnuTextSize, RcText, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER)
                'BitBlt lpDrawInfo.hdc, (lpDrawInfo.RcItem.Left + 1), (lpDrawInfo.RcItem.Top + 1), 16, 16, Form1!Picture1.hdc, (lpDrawInfo.itemID * 16), 0, vbSrcCopy
            End If
       
            If bSeparator Then      ' 画菜单分隔符
                Dim RcSep As RECT
                RcSep.Left = 3
                RcSep.Right = lpDrawInfo.RcItem.Right - 3
                RcSep.Top = lpDrawInfo.RcItem.Top + 2
                DrawEdge lpDrawInfo.hDc, RcSep, EDGE_ETCHED, BF_TOP
            End If
        End If
End Sub
  
Public Function PopMenu(hwnd As Long)
    Dim pt As POINTAPI
    Call GetCursorPos(pt)
    Call TrackPopupMenu(hMenu, TPM_LEFTALIGN, pt.X, pt.Y, 0, hwnd, ByVal 0&)
End Function

Private Sub Class_Initialize()
    hMenu = 0
End Sub
Private Sub Class_Terminate()
    If hMenu <> 0 Then
        DestroyWindow hMenu
    End If
End Sub

Public Sub SetMenuText(uItem As Long, mnuText As String, Optional uId As Long)
    ' 修该菜单文字和 ID (  :)可以当两个菜单使用)
    Dim lpcMenuItemInfo As MENUITEMINFO
    With lpcMenuItemInfo
        .cbSize = Len(lpcMenuItemInfo)
        .fMask = MIIM_ID
        .wID = uId
    End With
    Call SetMenuItemInfo(hMenu, uItem, True, lpcMenuItemInfo)
    MnuInfo(uItem).szItemText = mnuText
    MnuInfo(uItem).cchItemText = LenB(StrConv(mnuText, vbFromUnicode))
End Sub





'Public Sub OnInitMenuPopup(hMenuPopup As Long, nIndex As Long, Optional fSystemMenu As Boolean)
    ' 取菜单的信息并添加至VB 的集合 Msdn VC++
    ' 我开始是用的是 WM_INITMENUPOPUP 但不知为何会出现乱码.(而且集合不停的加) :(
    ' 如过你连系统菜单都要自己画的话就用 OnInitMenuPopup 消息具体如何可以参见 MSDN
    ' 原先我用集合来存储 菜单数据（因为要修改所以后改用数组）
   ' Dim lpcMenuItemInfo As MENUITEMINFOLONG
    'Dim MnuInfo As MYITEM
   ' Dim nItem As Long, I&
  '
 '   ReDim MnuInfo.szItemText(44)
'    nItem = GetMenuItemCount(hMenuPopup)
    
    'If Not fSystemMenu Then     ' Not OwnerDraw System Menu
   '     For I = 0 To nItem - 1
  '        '  With lpcMenuItemInfo
         '       .cbSize = Len(lpcMenuItemInfo)
        '        .fMask = MIIM_DATA Or MIIM_ID Or MIIM_TYPE
       '         .dwTypeData = VarPtr(MnuInfo.szItemText(0))
      '          .cch = UBound(MnuInfo.szItemText)
     '       End With
    '
         '   GetMenuItemInfo hMenuPopup, I, True, lpcMenuItemInfo
        
            ' Add Menu Type And Menu Text For VB Collection
            ' Set MFT_OWNERDRAW Type For Menu
        '    TypeMenu.Add lpcMenuItemInfo.fType
       '     strTextMenu.Add Left$(StrConv(MnuInfo.szItemText, vbUnicode), lpcMenuItemInfo.cch)
      '
     '       lpcMenuItemInfo.fMask = lpcMenuItemInfo.fMask Or MIIM_TYPE
    '        lpcMenuItemInfo.fType = MFT_OWNERDRAW   '
   '         Call SetMenuItemInfo(hMenuPopup, I, True, lpcMenuItemInfo)
  '      Next I
 '   End If
'End Sub