clsmenu.cls

一个clock的 vb 源码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' 本程序可以看看 MSDN
' 我建议大家参照 MSDN 然后自己写不要直接拷贝我的程序
' 因为这样你可能学不到东西。
' 用 VB 的集合来存储菜单的文字。(用API可以创建所有的菜单)
' 如果用物主绘图可以创建任何风格的菜单(Office 97, OICQ, Windows XP)
' (建议 从资源文件中创建菜单 你可以用 宝蓝的 Delphi 或 C++ 光盘中的
' Resource Workshop)来创建资源文件和对话框(以及基本的控件)
' 有那位能告诉我怎么从指针取结构的数据
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long

Private Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) 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 Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function SetMenuItemInfoLong Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFOLONG) As Long
Private Declare Function GetMenuItemInfoLong Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFOLONG) As Long

Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) 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, ByVal lprc As Any) As Long

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hDc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDc As Long, ByVal nBkMode As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long

' Format Text
Private Const DT_LEFT = &H0
Private Const DT_SINGLELINE = &H20
Private Const DT_VCENTER = &H4

Private Const TPM_LEFTALIGN = &H0&
Private Const SM_CYMENU = 15
Private Const NEWTRANSPARENT = 3  '  use with SetBkMode()

Private Const COLOR_MENU = 4
Private Const COLOR_MENUTEXT = 7
Private Const COLOR_HIGHLIGHTTEXT = 14

Private Const BF_LEFT = &H1              '边界矩形
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8            '全部边阶矩形
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const BDR_RAISEDINNER = &H4      '菜单小按钮式
Private Const BDR_SUNKENOUTER = &H2      '一种沉没外部的边阶式样
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)

' Font Size
Private Type SIZE
        CX As Long
        CY As Long
End Type

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

' GetCursorPos(鼠标指针的位置)
Private Type POINTAPI
    X As Long
    Y As Long
End Type

' 自己的结构
Private Type MYITEM
    cchItemText As Long
    szItemText As String
    dwTypeData As Long
End Type

' InsertMenuItem
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

' SetMenuItemInfo GetMenuItemInfo
Private Type MENUITEMINFOLONG
    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 Long
    cch As Long
End Type

' Message WM_MEASUREITEM Menu Width and Height
Private Type MEASUREITEMSTRUCT
        CtlType As Long
        CtlID As Long
        itemID As Long
        itemWidth As Long
        itemHeight As Long
        itemData As Long
End Type

' Message WM_DRAWITEM Draw Menu
Private Type DRAWITEMSTRUCT
        CtlType As Long                 '绘画得主人的菜单
        CtlID As Long                   '对菜单没用
        itemID As Long                  '菜单的索引ID
        itemAction As Long              '定义要求的绘画的行动
        itemState As Long               '绘画的行动发生以后，指定条款的视觉的状态 =选择
        hwndItem As Long                '指定菜单的柄( HMENU )为菜单包含条款
        hDc As Long                     '绘图的设备场景
        RcItem As RECT                  '一个矩形定义控制的边界被拉的 由hDC 成员指定。
        itemData As Long                'CMenu::ModifyMenu
        
End Type

' fMask To InsertMenuItem
Private Const MIIM_STATE = &H1
Private Const MIIM_ID = &H2
Private Const MIIM_SUBMENU = &H4
Private Const MIIM_CHECKMARKS = &H8
Private Const MIIM_TYPE = &H10
Private Const MIIM_DATA = &H20
Private Const MIIM_STRING = &H40
Private Const MIIM_BITMAP = &H80
Private Const MIIM_FTYPE = &H100

' fType To InsertMenuItem
Private Const MFT_BITMAP = &H4&
Private Const MFT_MENUBARBREAK = &H20&
Private Const MFT_OWNERDRAW = &H100&
Private Const MFT_SEPARATOR = &H800&
Private Const MFT_STRING = &H0&

' fState To InsertMenuItem
Private Const MFT_CHECKED = &H8&
Private Const MFT_DISABLED = &H2&
Private Const MFT_ENABLED = &H0&
Private Const MFT_GRAYED = &H1&
Private Const MFT_UNCHECKED = &H0&

Private Const ODT_MENU = 1
Private Const ODS_SELECTED = &H1

Private hMenu As Long
'Private SubhMenu As Long
Private mnuItemCound As Long
Private MnuInfo() As MYITEM

Public Function CreatePopMenu() As Long
    hMenu = CreatePopupMenu()
End Function

Public Function CreatePopSubMenu() As Long
    CreatePopSubMenu = CreatePopupMenu() ' 滴下的菜单
End Function

Public Sub AddSubMenu(mnuText As String, SubMenuID As Long, fType As Long, Optional fState As Long, Optional lngSubhMenu As Long)
    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    ' 添加子菜单项目
    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    Dim lpcMenuItemInfo As MENUITEMINFO
    With lpcMenuItemInfo
        .cbSize = Len(lpcMenuItemInfo)
        .fMask = MIIM_STRING Or MIIM_FTYPE Or MIIM_STATE Or MIIM_ID
        .fType = fType
        .fState = fState
        .cch = Len(mnuText)
        .dwTypeData = mnuText
        .wID = SubMenuID
    End With
    InsertMenuItem lngSubhMenu, SubMenuID, False, lpcMenuItemInfo
End Sub

Public Sub AddMenuItem(ID As Long, mnuText As String, fType As Long, Optional fState As Long, Optional subMenu As Boolean = False, Optional lngSubhMenu As Long)