CtrlPopupMenu.cls

 VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 1  'Persistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CtrlPopupMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Collection" ,"UserDefinedCollection"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
''' NotifyIconCtrl  v2.0

''' An Icon control for Windows 2000 written in Visual Basic

''' Copyright (C) 2000 Nathan Moschkin.

''' Free to copy and distribute, intact.  Give credit to me and anyone else
''' who may edit this code.

''' Please inquire before using any of this code or the OCX control commercially.
''' All Rights Reserved.

''' E-Mail questions or comments to nmosch@tampabay.rr.com



''' CtrlPopupMenu class for the NotifyIconCtrl Control.
''' Encapsulates the functionality of newer Windows Bitmapped menu items
''' not owner-drawn but that's coming soon.

''' Lets you add arrays of menu items like a collection.


Option Explicit

''' Private variables that represent public or semi-public properties

Private mCtrlIDNext As Integer

Private mParent As CtrlPopupMenu

Private mCol As Collection

Private mhMenu As Long

Private mMenuId As Long

Private mKey As String

Private mCaption As String

Private mPicture As StdPicture

Private mInfo As MENUITEMINFO

Private mBITMAP As OLE_HANDLE

Private mOSV5 As Boolean

Private meDefault As Long

Private meEnabled As Long

' fMask flags

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

'' New for Windows 98/2000

Private Const MIIM_STRING = &H40
Private Const MIIM_BITMAP = &H80
Private Const MIIM_FTYPE = &H100

'' End fMask flags

' Menu Flags

Private Const MF_INSERT = &H0&
Private Const MF_CHANGE = &H80&
Private Const MF_APPEND = &H100&
Private Const MF_DELETE = &H200&
Private Const MF_REMOVE = &H1000&

Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400&

Private Const MF_SEPARATOR = &H800&

Private Const MF_ENABLED = &H0&
Private Const MF_GRAYED = &H1&
Private Const MF_DISABLED = &H2&

Private Const MF_UNCHECKED = &H0&
Private Const MF_CHECKED = &H8&
Private Const MF_USECHECKBITMAPS = &H200&

Private Const MF_STRING = &H0&
Private Const MF_BITMAP = &H4&
Private Const MF_OWNERDRAW = &H100&

Private Const MF_POPUP = &H10&
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_MENUBREAK = &H40&

Private Const MF_UNHILITE = &H0&
Private Const MF_HILITE = &H80&

Private Const MF_DEFAULT = &H1000&
Private Const MF_SYSMENU = &H2000&
Private Const MF_HELP = &H4000&
Private Const MF_RIGHTJUSTIFY = &H4000&

Private Const MF_MOUSESELECT = &H8000&
Private Const MF_END = &H80&                    ' Obsolete -- only used by old RES files


Private Const MFT_STRING = MF_STRING
Private Const MFT_BITMAP = MF_BITMAP
Private Const MFT_MENUBARBREAK = MF_MENUBARBREAK
Private Const MFT_MENUBREAK = MF_MENUBREAK
Private Const MFT_OWNERDRAW = MF_OWNERDRAW
Private Const MFT_RADIOCHECK = &H200&
Private Const MFT_SEPARATOR = MF_SEPARATOR
Private Const MFT_RIGHTORDER = &H2000&
Private Const MFT_RIGHTJUSTIFY = MF_RIGHTJUSTIFY

Private Const MFS_GRAYED = &H3&
Private Const MFS_DISABLED = MFS_GRAYED
Private Const MFS_CHECKED = MF_CHECKED
Private Const MFS_HILITE = MF_HILITE
Private Const MFS_ENABLED = MF_ENABLED
Private Const MFS_UNCHECKED = MF_UNCHECKED
Private Const MFS_UNHILITE = MF_UNHILITE
Private Const MFS_DEFAULT = MF_DEFAULT

' New for Windows 2000/98

Private Const MFS_MASK = &H108B&
Private Const MFS_HOTTRACKDRAWN = &H10000000
Private Const MFS_CACHEDBMP = &H20000000
Private Const MFS_BOTTOMGAPDROP = &H40000000
Private Const MFS_TOPGAPDROP = &H80000000
Private Const MFS_GAPDROP = &HC0000000

' for the SetMenuInfo API function

Private Const MNS_NOCHECK = &H80000000
Private Const MNS_MODELESS = &H40000000
Private Const MNS_DRAGDROP = &H20000000
Private Const MNS_AUTODISMISS = &H10000000
Private Const MNS_NOTIFYBYPOS = &H8000000
Private Const MNS_CHECKORBMP = &H4000000

Private Const MIM_MAXHEIGHT = &H1
Private Const MIM_BACKGROUND = &H2
Private Const MIM_HELPID = &H4
Private Const MIM_MENUDATA = &H8
Private Const MIM_STYLE = &H10
Private Const MIM_APPLYTOSUBMENUS = &H80000000

''' Good ol' types...

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

Private Type MENU_EVENT_RECORD
        dwCommandId As Long
End Type

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
   
    ' Declared for Windows 2000/98.  Still backward compatible
   
    hbmpItem As Long
End Type

Private Type MENUITEMTEMPLATE
        mtOption As Integer
        mtID As Integer
        mtString As Byte
End Type

Private Type MENUITEMTEMPLATEHEADER
        versionNumber As Integer
        offset As Integer
End Type

Private Type TPMPARAMS
    cbSize As Long
    rcExclude As RECT
End Type

Public Enum CpmMenuTypes
    cpmItem = 1
    cpmMenu = 2
    cpmSubMenu = 3
End Enum

''' I just decided to declare the whole menu system API
''' never know when one of these functions will come in handy.

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 RECT) As Long
Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As Long, lpTPMParams As TPMPARAMS) As Long

Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function CreateMenu Lib "user32" () 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 GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuDefaultItem Lib "user32" (ByVal hMenu As Long, ByVal fByPos As Long, ByVal gmdiFlags As Long) As Long
Private Declare Function GetMenuContextHelpId Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetMenuCheckMarkDimensions Lib "user32" () As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) 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 GetMenuItemRect Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long, ByVal uItem As Long, lprcItem As RECT) As Long
Private Declare Function GetMenuState Lib "user32" (ByVal hMenu As Long, ByVal wID As Long, ByVal wFlags As Long) As Long
Private Declare Function GetMenuString Lib "user32" Alias "GetMenuStringA" (ByVal hMenu As Long, ByVal wIDItem As Long, ByVal lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) 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 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 SetMenuContextHelpId Lib "user32" (ByVal hMenu As Long, ByVal dw As Long) 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 SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked 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 RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

''' New for Windows 2000/98

Private Declare Function SetMenuInfo Lib "user32" (ByVal hMenu As Long, miINFO As MENUINFO) As Boolean

Private Type MENUINFO
    cbSize As Long
    fMask As Long
    dwStyle As Long
    cyMax As Integer
    Back As Long
    ContextHelpID As Long
    MenuData As Long
End Type

''' OS Version retrieval from kernel

Private Declare Function GetVersion Lib "kernel32" () As Long

Private Const IMAGE_BITMAP = 0

''' External interface to the Default state property

Public Property Let Default(ByVal vData As Boolean)
   
    If vData = True Then
        meDefault = MFS_DEFAULT
    Else
        meDefault = 0
    End If
   
    SetCtrlState
    PropertyChanged "Default"

End Property

Public Property Get Default() As Boolean
    GetCtrlState
   
    If meDefault <> 0 Then
        Default = True
    Else
        Default = False
    End If
   
End Property

Public Property Get Picture() As StdPicture
    Set Picture = mPicture
End Property

''' Set the bitmap of the image.
''' Automatically set either the new 2000/98 Bitmap option
''' or the checkmark bitmap.

Public Property Set Picture(vData As StdPicture)
    On Error Resume Next
   
    Set mPicture = vData
   
    If mParent Is Nothing Then Exit Property
   
    If Not mPicture Is Nothing Then
       
        '' Make sure the picture is indeed a bitmap.
        '' Window's menus don't support icons.
       
        If mPicture.Type = 1 Then
           
            mBITMAP = mPicture.Handle
            If mOSV5 = True Then
                mInfo.hbmpItem = mBITMAP
            Else
                mInfo.hbmpUnchecked = mBITMAP
                mInfo.hbmpChecked = 0
            End If
        End If
    Else
        '' Otherwise we can assume we are clearing the bitmaps.
       
        mInfo.hbmpUnchecked = 0
        mInfo.hbmpItem = 0
    End If
   
    If mOSV5 = True Then
        '' Windows 2000/98 supports the bitmap routine.
        mInfo.fMask = MIIM_BITMAP
    Else
        '' Windows 95/NT supports this one.
        mInfo.fMask = MIIM_CHECKMARKS
    End If
   
    SetMenuItemInfo mParent.hMenu, mMenuId, False, mInfo
       
    PropertyChanged "Picture"

End Property

Public Function Count() As Long
    Count = mCol.Count
End Function

''' The caption is the text displayed in the menu

Public Property Get Caption() As String
    GetCtrlState
    Caption = mCaption
End Property

Public Property Let Caption(ByVal vData As String)
    mCaption = vData
   
    SetCtrlState
    PropertyChanged "Caption"
   
End Property

''' The MenuID is assigned when the menu object is created, but
''' re-assigned when a menu is added to the collection.
''' The GetNewCtrlId function generates a CtrlID at the top most level
''' of the menu heirarchy.

Public Property Get MenuId() As Long
    MenuId = mMenuId
   
End Property

Friend Property Let MenuId(ByVal vData As Long)
    mMenuId = vData
    PropertyChanged "MenuID"
End Property

''' hMenu will only be present if there are sub menus in the collection

Public Property Get hMenu() As Long
    hMenu = mhMenu
End Property

''' Get the type of menu that this object represents: Toplevel, Submenu or
''' Menu Item.

Public Property Get MenuType() As CpmMenuTypes
    On Error Resume Next

    If hMenu = 0 Then
        MenuType = cpmItem
    ElseIf Parent Is Nothing Then
        MenuType = cpmMenu
    Else
        MenuType = cpmSubMenu
    End If
   
End Property

''' The Parent property is only present if this object does not represent
''' the topmost menu.

Public Property Get Parent() As CtrlPopupMenu
    Set Parent = mParent
End Property

Friend Property Set Parent(vData As CtrlPopupMenu)
    Set mParent = vData
    PropertyChanged "Parent"
End Property

    ' The search function will read the whole data collection.
    ' If it is textual, then it will search every menu and every
    ' submenu of every menu and so forth looking for a matching key.
    ' If it's an integer value, then we assume, that it refers directly to the
    ' MenuID assigned by the GetCtrlID function in CtrlPopupMenu
       
Public Function Search(ByVal vntIndexKey As Variant) As CtrlPopupMenu
    On Error Resume Next
   
    Dim v As CtrlPopupMenu, x As CtrlPopupMenu
       
   
    ''' If the vartype is an integer we do not assume that it
    ''' is an item identifier but a menu control identifier.
   
    ''' Note: Use Item() to get an item by the collection index.
   
    If VarType(vntIndexKey) = vbInteger Then
        If mMenuId = vntIndexKey Then
            Set Search = Me
            Exit Function
        End If
   
        For Each v In mCol
            If v.MenuId = vntIndexKey Then
                Set Search = v
                Exit Function
            Else
                Set x = Nothing
                Set x = v.Search(vntIndexKey)
                If Not x Is Nothing Then
                    Set Search = x
                    Exit Function
                End If
            End If
           
        Next v
   
    ElseIf VarType(vntIndexKey) = vbString Then
       
        ''' Otherwise we search recursively for a member
        ''' whos key matches this string expression
       
        Set x = Me.Item(vntIndexKey)
        If x Is Nothing Then
            For Each v In Me
                Set x = Nothing
                Set x = v.Search(vntIndexKey)
                If Not x Is Nothing Then
                    Set Search = x
                    Exit Function
                End If
            Next v
        Else
            Set Search = x
            Exit Function
        End If
   
    End If
   
End Function

Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
    Set NewEnum = mCol.[_NewEnum]
End Property

''' Get a new control ID for the menu interface

Friend Function GetNewCtrlId() As Integer
    On Error Resume Next
    Dim x As Object
   
    If Not Parent Is Nothing Then
        ''' If there is a parent to call on, we ask for a control
        ''' ID from it, and so on and so on.
       
        GetNewCtrlId = Parent.GetNewCtrlId
   
    Else
        ''' Make sure we're not assigning a control identity that
        ''' some one else already has...
       
        If mCtrlIDNext = 0 Then
            mCtrlIDNext = &H1024
        End If
               
        ''' Call the recursive search function to check every item
        ''' below this one.
       
        Set x = Me.Search(mCtrlIDNext)
       
        Do While Not x Is Nothing
            mCtrlIDNext = mCtrlIDNext + 1
            Set x = Nothing
            Set x = Me.Search(mCtrlIDNext)
        Loop
       
        GetNewCtrlId = mCtrlIDNext
        '' Increment the control ID.
       
        mCtrlIDNext = mCtrlIDNext + 1
       
    End If
   
End Function

''' The Key of the object

Public Property Let Key(ByVal vData As String)
    mKey = vData
End Property

Public Property Get Key() As String
    Key = mKey
End Property


''' Centralized functions for setting and getting certain aspects of a menu
''' item's control state such as the Enabled and Default properties.

Public Sub SetCtrlState()
    On Error Resume Next
   
    Dim vStr As String
   
    ''' if there is no parent, this menu item does not exist.
   
    If mParent Is Nothing Then Exit Sub
   
    ''' Set the caption along with the state
   
    vStr = "  " + mCaption + Chr(0)
   
    mInfo.dwTypeData = vStr
    mInfo.fState = meEnabled Or meDefault
   
    ' SetMenuItemInfo mParent.hMenu, mMenuId, False, mInfo
    mInfo.fMask = MIIM_STATE + MIIM_TYPE
   
    If mCaption <> "-" Then
        mInfo.fType = MFT_STRING
        mInfo.cch = Len(mCaption) + 1
    Else
        mInfo.fType = MFT_SEPARATOR
    End If
   
    SetMenuItemInfo mParent.hMenu, mMenuId, False, mInfo
   
End Sub

Public Sub GetCtrlState()
    On Error Resume Next
   
    ''' if there is no parent, this menu item does not exist.
       
    If mParent Is Nothing Then Exit Sub
   
    mInfo.fMask = MIIM_STATE + MIIM_TYPE
   
    GetMenuItemInfo mParent.hMenu, mMenuId, False, mInfo
   
    ''' Disabled/Enabled state
   
    If mInfo.fState And MFS_DISABLED Then
        meEnabled = MFS_DISABLED
    ElseIf mInfo.fState And MFS_ENABLED Then
        meEnabled = MFS_ENABLED
    End If
   
    ''' Default/Bold state
   
    If mInfo.fState And MFS_DEFAULT Then
        meDefault = MFS_DEFAULT
    Else
        meDefault = 0
    End If
   
   
    ''' Not implemented, for now.
   
'    If mInfo.fType = MFT_STRING Then
'        mCaption = Mid(mInfo.dwTypeData, 3, Len(mInfo.dwTypeData) - 3)
'    Else
'        mCaption = "-"
'    End If
   

End Sub

''' External interface to an items Enabled/Disabled properties

Public Property Let Enabled(ByVal vData As Boolean)
   
    If vData = True Then
        meEnabled = MFS_ENABLED
    Else
        meEnabled = MFS_DISABLED
    End If
   
    SetCtrlState
    PropertyChanged "Enabled"
   
End Property


Public Property Get Enabled() As Boolean
       
    GetCtrlState
   
    If meEnabled = MFS_ENABLED Then
        Enabled = True
    Else
        Enabled = False
    End If
   
End Property

''' Add a sub menu and return the menu item.

Public Function Add(ByVal TextStr As String, Optional vPicture As StdPicture, Optional ByVal sKey As String) As CtrlPopupMenu
    On Error Resume Next
   
    Dim x As MENUITEMINFO, vFlags As Long, xStr As String
    Dim vNewItem As New CtrlPopupMenu
   
    x.cbSize = Len(x)
       
    If mMenuId = 0 Then Exit Function
   
    ''' Create this menu as necessary...
   
    If mhMenu = 0 Then
        mhMenu = CreatePopupMenu
       
        ''' Set certain characteristics that we wish to have if
        ''' the OS supports it.
       
        If mOSV5 = True Then
            Dim m As MENUINFO
            m.cbSize = Len(m)
            m.fMask = MIM_STYLE
            m.dwStyle = MNS_CHECKORBMP
   
            SetMenuInfo mhMenu, m
        End If
   
        ''' If this is a sub menu, we need to tell the parent
        ''' menu that this item now links to a sub menu.
   
        If Not mParent Is Nothing Then
            mInfo.fMask = MIIM_SUBMENU + MIIM_ID
            mInfo.wID = mMenuId
            mInfo.hSubMenu = mhMenu
           
            SetMenuItemInfo Parent.hMenu, mMenuId, False, mInfo
        End If
       
    End If
   
    ''' Set the parent of the new item to this instance.
   
    Set vNewItem.Parent = Me
   
    ''' Use the highest possible level of the menu heiarchy to obtain
    ''' a new control ID.
   
    vNewItem.MenuId = GetNewCtrlId
   
    ''' If there is no key, it is the hexidecimal value of the control id.
   
    If sKey = "" Then
        vNewItem.Key = "H" + Hex(vNewItem.MenuId)
    Else
        vNewItem.Key = sKey
    End If
   
    ''' Menu items are strings. :)
   
    vFlags = vFlags + MF_STRING
   
    xStr = TextStr + Chr(0)
   
    ''' Use the old AppendMenu to quickly add a menu item.
   
    AppendMenu mhMenu, vFlags, vNewItem.MenuId, StrPtr(xStr)
   
    ''' Now set the item's properties so that they are picked up
    ''' by the physical control...
   
    vNewItem.Caption = TextStr
   
    If Not vPicture Is Nothing Then
        Set vNewItem.Picture = vPicture
    End If
   
    ''' Add the item to the collection
   
    mCol.Add vNewItem, vNewItem.Key
       
    Set Add = vNewItem
    Set vNewItem = Nothing
   
End Function

Public Sub Remove(ByVal vntIndexKey As Variant)
    On Error Resume Next
   
    mCol.Remove vntIndexKey
   
End Sub

Public Property Set Item(ByVal vntIndexKey As Variant, vData As CtrlPopupMenu)
    On Error Resume Next
   
    Set mCol(vntIndexKey) = vData
   
    PropertyChanged "Items"
   
End Property

Public Property Get Item(ByVal vntIndexKey As Variant) As CtrlPopupMenu
Attribute Item.VB_MemberFlags = "200"
    On Error Resume Next
   
    Set Item = mCol(vntIndexKey)
    If Item Is Nothing Then
        Set Item = Me.Search(vntIndexKey)
    End If

End Property

Public Sub Clear()
    Set mCol = New Collection
End Sub

''' Initialize default values of the function, assign a default
''' menu id, and determine the Operating System version

Private Sub Class_Initialize()
'     Set mCol = New Collection
    Dim l As Long
   
    Set mCol = New Collection
   
    mCtrlIDNext = &H1025
   
    l = GetVersion
    If (l And &HFF) = 5 Then
        mOSV5 = True
    End If
   
    If mOSV5 = True Then
        mInfo.cbSize = Len(mInfo)
    Else
        mInfo.cbSize = Len(mInfo) - 4
    End If
   
    mMenuId = mCtrlIDNext - 1
    mInfo.wID = mMenuId
   
    meEnabled = MFS_ENABLED
    meDefault = 0
   
End Sub

''' This class 'theoretically' supports persistance.

Private Sub Class_ReadProperties(PropBag As PropertyBag)
    On Error Resume Next
   
    Set mCol = PropBag.ReadProperty("Items", mCol)
   
    mMenuId = PropBag.ReadProperty("MenuID")
    If mMenuId = 0 Then
        mMenuId = mCtrlIDNext - 1
    End If
   
    meEnabled = PropBag.ReadProperty("Enabled", MFS_ENABLED)
    meDefault = PropBag.ReadProperty("Default", 0)
    mhMenu = PropBag.ReadProperty("MenuHandle", 0)
    mKey = PropBag.ReadProperty("Key", vbNullString)
    Set mParent = PropBag.ReadProperty("Parent", Nothing)
    mCaption = PropBag.ReadProperty("Caption", vbNullString)
    Set mPicture = PropBag.ReadProperty("Picture", Nothing)
       
    mInfo.wID = mMenuId

    SetCtrlState
End Sub

Private Sub Class_WriteProperties(PropBag As PropertyBag)
    On Error Resume Next
   
    GetCtrlState
   
    PropBag.WriteProperty "Items", mCol
    PropBag.WriteProperty "MenuID", mMenuId
    PropBag.WriteProperty "Enabled", meEnabled
    PropBag.WriteProperty "Default", meDefault
    PropBag.WriteProperty "MenuHandle", mhMenu
    PropBag.WriteProperty "Key", mKey
    PropBag.WriteProperty "Parent", mParent
    PropBag.WriteProperty "Caption", mCaption
    PropBag.WriteProperty "Picture", mPicture
           
End Sub

''' Destroy the sub menus first, or we will generate an exception.
''' You must destroy the menus before terminating the class.

Public Sub Destroy()
    Dim v As CtrlPopupMenu
    On Error Resume Next
   
    If mCol.Count > 0 Then
   
        For Each v In mCol
            If v.hMenu <> 0 Then
                ''' This menu has a sub menu, so we destroy the sub menus
                ''' and handles first.
               
                v.Destroy
            End If
           
            ''' Now delete the item entry in this menu.
           
            DeleteMenu mhMenu, v.MenuId, 0
        Next v
       
        Set mCol = Nothing
       
        ''' No more items in the menu,
        ''' delete the menu.
       
        DestroyMenu mhMenu
    End If
   
End Sub

''' Automatically destroy the whole thing on terminate.

Private Sub Class_Terminate()
    Me.Destroy
End Sub

Project Homepage: