vbAccelerator - Contents of code file: cPopMenu.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cIconMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit



Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type

' =======================================================================
' MENU private declares:
' =======================================================================

' Menu flag constants:
Private Const MF_APPEND = &H100&
Private Const MF_BITMAP = &H4&
Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400&
Private Const MF_CALLBACKS = &H8000000
Private Const MF_CHANGE = &H80&
Private Const MF_CHECKED = &H8&
Private Const MF_CONV = &H40000000
Private Const MF_DELETE = &H200&
Private Const MF_DISABLED = &H2&
Private Const MF_ENABLED = &H0&
Private Const MF_END = &H80
Private Const MF_ERRORS = &H10000000
Private Const MF_GRAYED = &H1&
Private Const MF_HELP = &H4000&
Private Const MF_HILITE = &H80&
Private Const MF_HSZ_INFO = &H1000000
Private Const MF_INSERT = &H0&
Private Const MF_LINKS = &H20000000
Private Const MF_MASK = &HFF000000
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_MENUBREAK = &H40&
Private Const MF_MOUSESELECT = &H8000&
Private Const MF_OWNERDRAW = &H100&
Private Const MF_POPUP = &H10&
Private Const MF_POSTMSGS = &H4000000
Private Const MF_REMOVE = &H1000&
Private Const MF_SENDMSGS = &H2000000
Private Const MF_SEPARATOR = &H800&
Private Const MF_STRING = &H0&
Private Const MF_SYSMENU = &H2000&
Private Const MF_UNCHECKED = &H0&
Private Const MF_UNHILITE = &H0&
Private Const MF_USECHECKBITMAPS = &H200&
Private Const MF_DEFAULT = &H1000&

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&

' New versions of the names...
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

' MenuItemInfo Mask constants
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 SC_RESTORE = &HF120&
Private Const SC_MOVE = &HF010&
Private Const SC_SIZE = &HF000&
Private Const SC_MAXIMIZE = &HF030&
Private Const SC_MINIMIZE = &HF020&
Private Const SC_CLOSE = &HF060&
     
Private Const SC_ARRANGE = &HF110&
Private Const SC_HOTKEY = &HF150&
Private Const SC_HSCROLL = &HF080&
Private Const SC_KEYMENU = &HF100&
Private Const SC_MOUSEMENU = &HF090&
Private Const SC_NEXTWINDOW = &HF040&
Private Const SC_PREVWINDOW = &HF050&
Private Const SC_SCREENSAVE = &HF140&
Private Const SC_TASKLIST = &HF130&
Private Const SC_VSCROLL = &HF070&
Private Const SC_ZOOM = SC_MAXIMIZE
Private Const SC_ICON = SC_MINIMIZE

' Owner draw information:
Private Const ODS_CHECKED = &H8
Private Const ODS_DISABLED = &H4
Private Const ODS_FOCUS = &H10
Private Const ODS_GRAYED = &H2
Private Const ODS_SELECTED = &H1
Private Const ODT_BUTTON = 4
Private Const ODT_COMBOBOX = 3
Private Const ODT_LISTBOX = 2
Private Const ODT_MENU = 1

' GetDeviceCaps
Private Const BITSPIXEL = 12

Private Type MEASUREITEMSTRUCT
   CtlType As Long
   CtlID As Long
   itemID As Long
   itemWidth As Long
   itemHeight As Long
   ItemData As Long
End Type

Private Type DRAWITEMSTRUCT
   CtlType As Long
   CtlID As Long
   itemID As Long
   itemAction As Long
   itemState As Long
   hwndItem As Long
   hdc As Long
   rcItem As RECT
   ItemData 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 Long
   cch As Long
End Type
Private Type MENUITEMINFO_STRINGDATA
   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 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 Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal
 bRevert As Long) As Long
Private Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, 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 GetMenuCheckMarkDimensions Lib "user32" () As Long
Private Declare Function GetMenuContextHelpId Lib "user32" (ByVal hMenu 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 GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As
 Long
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA"
 (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Boolean,
 lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function GetMenuItemInfoStr Lib "user32" Alias
 "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal
 fByPosition As Boolean, lpMenuItemInfo As MENUITEMINFO_STRINGDATA) 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 SetMenuItemInfoStr Lib "user32" Alias
 "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As
 Boolean, lpcMenuItemInfo As MENUITEMINFO_STRINGDATA) 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 CreateMenu Lib "user32" () As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function CreatePopupMenu Lib "user32" () As Long

Private Declare Function AppendMenuBylong Lib "user32" Alias "AppendMenuA"
 (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal
 lpNewItem As Long) As Long
Private Declare Function AppendMenuByString Lib "user32" Alias "AppendMenuA"
 (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal
 lpNewItem As String) 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 ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal
 hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem
 As Long, ByVal lpString As Any) As Long
Private Declare Function ModifyMenuByLong Lib "user32" Alias "ModifyMenuA"
 (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal
 wIDNewItem As Long, ByVal lpString As Long) 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 InsertMenuByLong Lib "user32" Alias "InsertMenuA"
 (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal
 wIDNewItem As Long, ByVal lpNewItem As Long) As Long
Private Declare Function InsertMenuByString Lib "user32" Alias "InsertMenuA"
 (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal
 wIDNewItem As Long, ByVal lpNewItem As String) As Long
Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA"
 (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo
 As MENUITEMINFO) 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 EnableMenuItem Lib "user32" (ByVal hMenu As Long,
 ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
Private Declare Function HiliteMenuItem Lib "user32" (ByVal hwnd As Long, ByVal
 hMenu As Long, ByVal wIDHiliteItem As Long, ByVal wHilite As Long) As Long

Private Declare Function MenuItemFromPoint Lib "user32" (ByVal hwnd As Long,
 ByVal hMenu As Long, ByVal ptScreen As POINTAPI) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal
 nPos As Long) As Long


' =======================================================================
' GDI private declares:
' =======================================================================

Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal
 lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As
 Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As
 Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long,
 ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) 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 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 SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal
 nBkMode As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function DrawEdgeAPI Lib "user32" Alias "DrawEdge" (ByVal hdc
 As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
' Pen functions:
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
 nWidth As Long, ByVal crColor As Long) As Long
    Private Const PS_DASH = 1
    Private Const PS_DASHDOT = 3
    Private Const PS_DASHDOTDOT = 4
    Private Const PS_DOT = 2
    Private Const PS_SOLID = 0
    Private Const PS_NULL = 5
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long)
 As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function DrawState Lib "user32" Alias "DrawStateA" _
   (ByVal hdc As Long, ByVal hBrush As Long, _
   ByVal lpDrawStateProc As Long, _
   ByVal lParam As Long, ByVal wParam As Long, _
   ByVal x As Long, ByVal y As Long, _
   ByVal cX As Long, ByVal cY As Long, _
   ByVal fuFlags As Long) As Long

'/* Image type */
Private Const DST_COMPLEX = &H0
Private Const DST_TEXT = &H1
Private Const DST_PREFIXTEXT = &H2
Private Const DST_ICON = &H3
Private Const DST_BITMAP = &H4

' /* State type */
Private Const DSS_NORMAL = &H0
Private Const DSS_UNION = &H10         ' /* Gray string appearance */
Private Const DSS_DISABLED = &H20
Private Const DSS_MONO = &H80
Private Const DSS_RIGHT = &H8000

Private Const DT_BOTTOM = &H8
Private Const DT_CENTER = &H1
Private Const DT_LEFT = &H0
Private Const DT_CALCRECT = &H400
Private Const DT_WORDBREAK = &H10
Private Const DT_VCENTER = &H4
Private Const DT_TOP = &H0
Private Const DT_TABSTOP = &H80
Private Const DT_SINGLELINE = &H20
Private Const DT_RIGHT = &H2
Private Const DT_NOCLIP = &H100
Private Const DT_INTERNAL = &H1000
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_EXPANDTABS = &H40
Private Const DT_CHARSTREAM = 4
Private Const DT_NOPREFIX = &H800
Private Const DT_EDITCONTROL = &H2000&
Private Const DT_PATH_ELLIPSIS = &H4000&
Private Const DT_END_ELLIPSIS = &H8000&
Private Const DT_MODIFYSTRING = &H10000
Private Const DT_RTLREADING = &H20000
Private Const DT_WORD_ELLIPSIS = &H40000

Private Const OPAQUE = 2
Private Const TRANSPARENT = 1

' DrawEdge:
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENINNER = &H8

Private Const BDR_OUTER = &H3
Private Const BDR_INNER = &HC
Private Const BDR_RAISED = &H5
Private Const BDR_SUNKEN = &HA

Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)

Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8

Private Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)

Private Const CLR_INVALID = -1

Private Declare Function ImageList_GetIconSize Lib "COMCTL32.DLL" ( _
        ByVal hIml As Long, _
        cX As Long, cY As Long _
    ) As Long
Private Declare Function ImageList_GetImageRect Lib "COMCTL32.DLL" ( _
        ByVal hIml As Long, _
        ByVal i As Long, _
        prcImage As RECT _
    ) As Long
Private Declare Function ImageList_Draw Lib "COMCTL32.DLL" ( _
        ByVal hIml As Long, ByVal i As Long, _
        ByVal hdcDst As Long, ByVal x As Long, ByVal y As Long, _
        ByVal fStyle As Long _
    ) As Long
' Create a new icon based on an image list icon:
Private Declare Function ImageList_GetIcon Lib "COMCTL32.DLL" ( _
        ByVal hIml As Long, _
        ByVal i As Long, _
        ByVal diIgnore As Long _
    ) As Long
Private Declare Function ImageList_GetImageCount Lib "COMCTL32.DLL" ( _
        ByVal hIml As Long _
    ) As Long
Private Declare Function ImageList_Create Lib "COMCTL32" (ByVal MinCx As Long,
 ByVal MinCy As Long, ByVal flags As Long, ByVal cInitial As Long, ByVal cGrow
 As Long) As Long
Private Declare Function ImageList_AddMasked Lib "COMCTL32" (ByVal hImageList
 As Long, ByVal hbmImage As Long, ByVal crMask As Long) As Long
Private Declare Function ImageList_Destroy Lib "COMCTL32" (ByVal hImageList As
 Long) As Long
Private Const ILD_NORMAL = 0
Private Const ILD_TRANSPARENT = 1
Private Const ILD_BLEND25 = 2
Private Const ILD_SELECTED = 4
Private Const ILD_FOCUS = 4
Private Const ILD_MASK = &H10&
Private Const ILD_IMAGE = &H20&
Private Const ILD_ROP = &H40&
Private Const ILD_OVERLAYMASK = 3840
Private Const ILC_COLOR = &H0
Private Const ILC_COLOR32 = &H20
Private Const ILC_MASK = &H1&

' =======================================================================
' General Win private declares:
' =======================================================================
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As
 Any, pSrc As Any, ByVal ByteLen As Long)

Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function MapWindowPoints Lib "user32" (ByVal hwndFrom As Long,
 ByVal hwndTo As Long, lppt As Any, ByVal cPoints As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long,
 lpPoint As POINTAPI) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
 Integer
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal
 nIndex As Long) As Long

Private Const HWND_DESKTOP = 0


' Window Messages
Private Const WM_DESTROY = &H2
Private Const WM_SETTEXT = &HC
Private Const WM_WININICHANGE = &H1A
Private Const WM_ACTIVATEAPP = &H1C
Private Const WM_CANCELMODE = &H1F
Private Const WM_SETCURSOR = &H20
Private Const WM_MEASUREITEM = &H2C
Private Const WM_DRAWITEM = &H2B
Private Const WM_STYLECHANGING = &H7C
Private Const WM_STYLECHANGED = &H7D
Private Const WM_NCCALCSIZE = &H83
Private Const WM_NCHITTEST = &H84
Private Const WM_NCPAINT = &H85
Private Const WM_NCACTIVATE = &H86
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_NCLBUTTONUP = &HA2
Private Const WM_NCLBUTTONDBLCLK = &HA3
Private Const WM_KEYDOWN = &H100
Private Const WM_COMMAND = &H111
Private Const WM_SYSCOMMAND = &H112
Private Const WM_INITMENUPOPUP = &H117
Private Const WM_MENUSELECT = &H11F
Private Const WM_MENUCHAR = &H120
Private Const WM_MDIGETACTIVE = &H229
Private Const WM_ENTERMENULOOP = &H211
Private Const WM_EXITMENULOOP = &H212


' =======================================================================
' IMPLEMENTATION
' =======================================================================

Public Enum ECPHighlightStyleConstants
   ECPHighlightStyleStandard = 0
   ECPHighlightStyleGradient = 1
   ECPHighlightStyleButton = 2
End Enum

Private m_cMemDC As cMemDC
Private m_cBitmap As cMemDC
Private m_cNCM As cNCMetrics
Private m_cBrush As cDottedBrush

Private m_hWnd As Long

Private m_oActiveMenuColor As OLE_COLOR
Private m_oInActiveMenuColor As OLE_COLOR
Private m_oMenuBackgroundColor As OLE_COLOR

Private m_fnt As StdFont
Private m_fntSymbol As StdFont
Private m_pic As IPicture

Private m_eHighlightStyle As ECPHighlightStyleConstants

Private m_iRestore As Long
Private m_hMenuRestore() As Long
Private m_iMenuPosition() As Long
Private m_tMIIS() As MENUITEMINFO_STRINGDATA
Private m_sCaption() As String
Private m_sShortCut() As String
Private m_sAccelerator() As String
Private m_lMenuTextSize() As Long
Private m_lMenuShortCutSize() As Long

Private m_iHaveSeenCount As Long
Private m_hMenuSeen() As Long

Private m_lMenuItemHeight As Long

Private m_colIcons As New Collection
Private m_hIml As Long
Private m_ptrVb6ImageList As Long
Private m_lIconSize As Long
Private m_OfficeXPStyle As Boolean

Implements ISubclass

Public Property Get OfficeXpStyle() As Boolean
Attribute OfficeXpStyle.VB_Description = "Gets/sets whether the menu draws
 using the Office XP style."
   OfficeXpStyle = m_OfficeXPStyle
End Property

Public Property Let OfficeXpStyle(ByVal bState As Boolean)
   m_OfficeXPStyle = bState
End Property

Public Property Let ImageList( _
        ByRef vImageList As Variant _
    )
Attribute ImageList.VB_Description = "Gets/sets the ImageList to use when
 drawing the icons."
    m_hIml = 0
    m_ptrVb6ImageList = 0
    If (VarType(vImageList) = vbLong) Then
        ' Assume a handle to an image list:
        m_hIml = vImageList
    ElseIf (VarType(vImageList) = vbObject) Then
        ' Assume a VB image list:
        On Error Resume Next
        ' Get the image list initialised..
        vImageList.ListImages(1).Draw 0, 0, 0, 1
        m_hIml = vImageList.hImageList
        If (Err.Number = 0) Then
            ' Check for VB6 image list:
            If (TypeName(vImageList) = "ImageList") Then
               Dim o As Object
               Set o = vImageList
               m_ptrVb6ImageList = ObjPtr(o)
            End If
        Else
            Debug.Print "Failed to Get Image list Handle", "cVGrid.ImageList"
        End If
        On Error GoTo 0
    End If
    If (m_hIml <> 0) Then
        If (m_ptrVb6ImageList <> 0) Then
            m_lIconSize = vImageList.ImageHeight
        Else
            Dim rc As RECT
            ImageList_GetImageRect m_hIml, 0, rc
            m_lIconSize = rc.bottom - rc.top
        End If
    End If
End Property

Public Property Get IconIndex(ByVal sCaption As String) As Long
Attribute IconIndex.VB_Description = "Gets/sets the 0-based index of the icon
 to be displayed against the menu item with the specified text."
   IconIndex = m_colIcons.Item(sCaption)
End Property
Public Property Get IconIndexForIndex(ByVal lItem As Long) As Long
   IconIndexForIndex = m_colIcons.Item(lItem)
End Property
Public Property Let IconIndex(ByVal sCaption As String, ByVal nIndex As Long)
   If nIndex = -1 Then
      m_colIcons.Remove sCaption
   Else
      On Error Resume Next
      m_colIcons.Item sCaption
      If Err.Number = 0 Then
         m_colIcons.Remove sCaption
      End If
      On Error GoTo 0
      m_colIcons.Add nIndex, sCaption
   End If
End Property
Public Sub IconItemCaptionChanged(ByVal sOldCaption As String, ByVal
 sNewCaption As String)
Attribute IconItemCaptionChanged.VB_Description = "If the caption of a menu
 item is changed in code, call this method to ensure any icon associated with
 the item still displays."
Dim lIdx As Long
   lIdx = -1
   On Error Resume Next
   lIdx = m_colIcons.Item(sOldCaption)
   If lIdx > -1 Then
      m_colIcons.Remove sOldCaption
      m_colIcons.Add lIdx, sNewCaption
   End If
End Sub
Public Property Get IconItemCount() As Long
Attribute IconItemCount.VB_Description = "Gets the total number of icons
 associated with menu items in the object."
   IconItemCount = m_colIcons.Count
End Property
Public Sub ClearIcons()
Attribute ClearIcons.VB_Description = "Clears all the icons associated with
 menu items in the control."
   Set m_colIcons = New Collection
End Sub
Public Property Get HighlightStyle() As ECPHighlightStyleConstants
Attribute HighlightStyle.VB_Description = "Gets/sets the highlight style of the
 menu items."
   HighlightStyle = m_eHighlightStyle
End Property
Public Property Let HighlightStyle(ByVal eStyle As ECPHighlightStyleConstants)
   m_eHighlightStyle = eStyle
End Property
Private Property Get hFontSymbol() As Long
Dim iFn As IFont
   Set iFn = m_fntSymbol
   hFontSymbol = iFn.hFont
End Property
Friend Property Let Font( _
      fntTHis As StdFont _
   )
   pSetFont fntTHis
End Property
Public Property Set Font( _
      fntTHis As StdFont _
   )
Attribute Font.VB_Description = "Gets/sets the font used to draw the menu text.
 Set to nothing to use the default menu font."
   pSetFont fntTHis
End Property
Public Property Get Font() As StdFont
Dim lHDC As Long
   If m_fnt Is Nothing Then
      lHDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
      Set Font = m_cNCM.Font(lHDC, MenuFOnt)
      DeleteDC lHDC
   Else
      Set Font = m_fnt
   End If
End Property
Private Sub pSetFont(fntTHis As StdFont)
   Set m_fnt = fntTHis
   m_fntSymbol.Size = Font.Size * 1.2
End Sub
Public Property Get BackgroundPicture() As IPicture
Attribute BackgroundPicture.VB_Description = "Gets/sets a background bitmap to
 show in the menu."
   Set BackgroundPicture = m_pic
End Property
Public Property Let BackgroundPicture(ByRef iPic As IPicture)
   pSetPicture iPic
End Property
Public Property Set BackgroundPicture(ByRef iPic As IPicture)
   pSetPicture iPic
End Property
Private Sub pSetPicture(ByRef iPic As IPicture)
   If Not iPic Is Nothing Then
      Set m_pic = iPic
      Set m_cBitmap = New cMemDC
      m_cBitmap.CreateFromPicture iPic
   Else
      Set m_cBitmap = Nothing
   End If
End Sub
Public Property Let ActiveMenuForeColor(ByVal oColor As OLE_COLOR)
Attribute ActiveMenuForeColor.VB_Description = "Gets/sets the foreground colour
 of an active menu item. Set to -1 to use the default colours."
   m_oActiveMenuColor = oColor
End Property
Public Property Get ActiveMenuForeColor() As OLE_COLOR
   If m_oActiveMenuColor = CLR_INVALID Then
      If (m_OfficeXPStyle) Then
         ActiveMenuForeColor = vbMenuText
      Else
         ActiveMenuForeColor = vbHighlightText
      End If
   Else
      ActiveMenuForeColor = m_oActiveMenuColor
   End If
End Property
Public Property Let InActiveMenuForeColor(ByVal oColor As OLE_COLOR)
Attribute InActiveMenuForeColor.VB_Description = "Gets/sets the colour to draw
 inactive (non-selected) menu item captions.  Set to -1 to use the default
 colours."
   m_oInActiveMenuColor = oColor
End Property
Public Property Get InActiveMenuForeColor() As OLE_COLOR
   If m_oInActiveMenuColor = CLR_INVALID Then
      InActiveMenuForeColor = vbMenuText
   Else
      InActiveMenuForeColor = m_oInActiveMenuColor
   End If
End Property
Public Property Let MenuBackgroundColor(ByVal oColor As OLE_COLOR)
Attribute MenuBackgroundColor.VB_Description = "Gets/sets the background colour
 of the menu items.  Set to -1 to use the default colours."
   m_oMenuBackgroundColor = oColor
End Property
Public Property Get MenuBackgroundColor() As OLE_COLOR
   If m_oMenuBackgroundColor = CLR_INVALID Then
      MenuBackgroundColor = vbMenuBar
   Else
      MenuBackgroundColor = m_oMenuBackgroundColor
   End If
End Property
Private Property Get hFont() As Long
Dim iFn As IFont
   Set iFn = Font
   hFont = iFn.hFont
End Property
Public Sub Attach(ByVal lhWnd As Long)
Attribute Attach.VB_Description = "Connects this object to a form to and starts
 customising the menus."
   Detach
   m_hWnd = lhWnd
   AttachMessage Me, m_hWnd, WM_WININICHANGE
   AttachMessage Me, m_hWnd, WM_DRAWITEM
   AttachMessage Me, m_hWnd, WM_MEASUREITEM
   AttachMessage Me, m_hWnd, WM_MENUCHAR
   AttachMessage Me, m_hWnd, WM_INITMENUPOPUP
   AttachMessage Me, m_hWnd, WM_EXITMENULOOP
   AttachMessage Me, m_hWnd, WM_DESTROY
End Sub
Public Sub Detach()
Attribute Detach.VB_Description = "Detaches this object from a form it was
 previously attached to and clears up all menu customisation."
   If Not m_hWnd = 0 Then
      DetachMessage Me, m_hWnd, WM_WININICHANGE
      DetachMessage Me, m_hWnd, WM_DRAWITEM
      DetachMessage Me, m_hWnd, WM_MEASUREITEM
      DetachMessage Me, m_hWnd, WM_MENUCHAR
      DetachMessage Me, m_hWnd, WM_INITMENUPOPUP
      DetachMessage Me, m_hWnd, WM_EXITMENULOOP
      DetachMessage Me, m_hWnd, WM_DESTROY
   End If
End Sub

Private Sub OwnerDrawMenu(ByVal hMenu As Long)
Dim lC As Long
Dim tMIIS As MENUITEMINFO_STRINGDATA
Dim tMII As MENUITEMINFO
Dim iMenu As Long
Dim sCap As String
Dim sShortCut As String
Dim tR As RECT
Dim iPos As Long
Dim lID As Long
Dim bHaveSeen As Boolean
Dim hFntOld As Long
Dim lMenuTextSize As Long
Dim lMenuShortCutSize As Long
Dim i As Long
                  
   ' Set OD flag on the fly...
   bHaveSeen = pbHaveSeen(hMenu)

   hFntOld = SelectObject(m_cMemDC.hdc, hFont)
   lC = GetMenuItemCount(hMenu)
   For iMenu = 0 To lC - 1
      
      If Not bHaveSeen Then

         tMIIS.fMask = MIIM_TYPE Or MIIM_DATA Or MIIM_ID
         tMIIS.cch = 127
         tMIIS.dwTypeData = String$(128, 0)
         tMIIS.cbSize = LenB(tMIIS)
         GetMenuItemInfoStr hMenu, iMenu, True, tMIIS
         'Debug.Print "New Item", tMIIS.dwTypeData

         lID = plAddToRestoreList(hMenu, iMenu, tMIIS)

         If Not (tMIIS.fType And MFT_OWNERDRAW) = MFT_OWNERDRAW Then
            ' Setting this flag causes tMIIS.dwTypeData to be
            ' overwritten with our own app-defined value:
            tMII.fType = tMIIS.fType Or MFT_OWNERDRAW And Not MFT_STRING
            tMII.dwItemData = lID
            tMII.cbSize = LenB(tMII)
            tMII.fMask = MIIM_TYPE Or MIIM_DATA
            SetMenuItemInfo hMenu, iMenu, True, tMII
         End If

      Else

         tMII.fMask = MIIM_TYPE Or MIIM_DATA Or MIIM_ID
         tMII.cbSize = Len(tMIIS)
         ReDim b(0 To 128) As Byte
         tMII.dwTypeData = VarPtr(b(0))
         GetMenuItemInfo hMenu, iMenu, True, tMII
         lID = tMII.dwItemData

         If Not ((tMII.fType And MFT_OWNERDRAW) = MFT_OWNERDRAW) Then

            lID = plReplaceIndex(hMenu, iMenu)

            'Debug.Print "VB has done something to it!", lID
            tMIIS.fMask = MIIM_TYPE Or MIIM_DATA Or MIIM_ID
            tMIIS.cch = 127
            tMIIS.dwTypeData = String$(128, 0)
            tMIIS.cbSize = LenB(tMIIS)
            GetMenuItemInfoStr hMenu, iMenu, True, tMIIS
'
            If lID = 0 Then
               ' New item,just added:
               lID = plAddToRestoreList(hMenu, iMenu, tMIIS)
            Else
               ' replacing existing:
               pReplaceRestoreList lID, hMenu, iMenu, tMIIS
            End If

            ' Setting this flag causes tMIIS.dwTypeData to be
            ' overwritten with our own app-defined value:
            tMII.fType = tMIIS.fType Or MFT_OWNERDRAW And Not MFT_STRING
            tMII.dwItemData = lID
            tMII.cbSize = LenB(tMII)
            tMII.fMask = MIIM_TYPE Or MIIM_DATA
            SetMenuItemInfo hMenu, iMenu, True, tMII

         End If

      End If

      If lID > 0 And lID <= m_iRestore Then
         sCap = m_sCaption(lID)
         sShortCut = m_sShortCut(lID)

         'Debug.Print m_sCaption(lID), m_sShortCut(lID)

         DrawText m_cMemDC.hdc, sCap, -1, tR, DT_LEFT Or DT_SINGLELINE Or
          DT_CALCRECT
         If tR.right - tR.left + 1 > lMenuTextSize Then
            lMenuTextSize = tR.right - tR.left + 1
         End If
         If Len(sShortCut) > 0 Then
            DrawText m_cMemDC.hdc, sShortCut, -1, tR, DT_LEFT Or DT_SINGLELINE
             Or DT_CALCRECT
            If tR.right - tR.left + 1 > lMenuShortCutSize Then
               lMenuShortCutSize = tR.right - tR.left + 1
            End If
         End If
         m_lMenuItemHeight = tR.bottom - tR.top + 2
         If m_lMenuItemHeight < m_lIconSize - 1 Then
            m_lMenuItemHeight = m_lIconSize - 1
         End If

      Else
         'Debug.Print "ERROR! ERROR! ERROR!"
      End If
      
   Next iMenu
   
   For i = 1 To m_iRestore
      If m_hMenuRestore(i) = hMenu Then
         m_lMenuTextSize(i) = lMenuTextSize
         m_lMenuShortCutSize(i) = lMenuShortCutSize
      End If
   Next i
   
   SelectObject m_cMemDC.hdc, hFntOld
   
End Sub
Private Function pbHaveSeen(ByVal hMenu As Long) As Boolean
   
   ' When WM_INITMENUPOPUP fires, this may or not be
   ' a new menu.  We use an array to store which menus
   ' we've already worked on:

Dim i As Long
   
   For i = 1 To m_iHaveSeenCount
      If hMenu = m_hMenuSeen(i) Then
         pbHaveSeen = True
         Exit Function
      End If
   Next i
   m_iHaveSeenCount = m_iHaveSeenCount + 1
   ReDim Preserve m_hMenuSeen(1 To m_iHaveSeenCount) As Long
   m_hMenuSeen(m_iHaveSeenCount) = hMenu

End Function
Private Function plReplaceIndex(ByVal hMenu As Long, ByVal iMenu As Long)
Dim i As Long
   For i = 1 To m_iRestore
      If m_hMenuRestore(i) = hMenu Then
         If m_iMenuPosition(i) = iMenu Then
            plReplaceIndex = i
            Exit Function
         End If
      End If
   Next i
End Function
Private Function plAddToRestoreList(ByVal hMenu As Long, ByVal iMenu As Long,
 tMIIS As MENUITEMINFO_STRINGDATA) As Long
   
   ' Here we store information about a menu item.  When the
   ' menus are closed again we can reset things back to the
   ' way they were using this struct.

   m_iRestore = m_iRestore + 1
   ReDim Preserve m_hMenuRestore(1 To m_iRestore) As Long
   ReDim Preserve m_iMenuPosition(1 To m_iRestore) As Long
   ReDim Preserve m_tMIIS(1 To m_iRestore) As MENUITEMINFO_STRINGDATA
   ReDim Preserve m_sCaption(1 To m_iRestore) As String
   ReDim Preserve m_sShortCut(1 To m_iRestore) As String
   ReDim Preserve m_sAccelerator(1 To m_iRestore) As String
   ReDim Preserve m_lMenuTextSize(1 To m_iRestore) As Long
   ReDim Preserve m_lMenuShortCutSize(1 To m_iRestore) As Long
   pReplaceRestoreList m_iRestore, hMenu, iMenu, tMIIS
   plAddToRestoreList = m_iRestore

End Function
Private Sub pReplaceRestoreList(ByVal lIdx As Long, hMenu As Long, iMenu As
 Long, tMIIS As MENUITEMINFO_STRINGDATA)
Dim sCap As String
Dim sShortCut As String
Dim iPos As Long

   m_hMenuRestore(lIdx) = hMenu
   m_iMenuPosition(lIdx) = iMenu
   LSet m_tMIIS(lIdx) = tMIIS
   If tMIIS.cch > 0 Then
      sCap = left$(tMIIS.dwTypeData, tMIIS.cch)
   Else
      sCap = ""
   End If
   iPos = InStr(sCap, vbTab)
   If iPos > 0 Then
      m_sShortCut(lIdx) = Mid$(sCap, iPos + 1)
      m_sCaption(lIdx) = left$(sCap, iPos - 1)
   Else
      m_sCaption(lIdx) = sCap
      m_sShortCut(lIdx) = ""
   End If
   iPos = InStr(m_sCaption(lIdx), "&")
   If iPos > 0 And iPos < Len(m_sCaption(lIdx)) Then
      m_sAccelerator(lIdx) = UCase$(Mid$(m_sCaption(lIdx), iPos + 1, 1))
   End If
End Sub
Private Function InternalIDForWindowsID(ByVal wID As Long) As Long
Dim i As Long
   ' linear search I'm afraid, but it is only called once
   ' per menu item shown (when WM_MEASUREITEM is fired)
   For i = 1 To m_iRestore
      If m_tMIIS(i).wID = wID Then
         InternalIDForWindowsID = i
         Exit Function
      End If
   Next i
End Function
Private Sub pRestoreList()
Dim i As Long
   'Debug.Print "RESTORELIST"
   ' erase the lot:
   For i = 1 To m_iRestore
      SetMenuItemInfoStr m_hMenuRestore(i), m_iMenuPosition(i), True, m_tMIIS(i)
   Next i
   m_iRestore = 0
   Erase m_hMenuRestore
   Erase m_iMenuPosition
   Erase m_tMIIS
   Erase m_sCaption()
   Erase m_sShortCut()
   Erase m_sAccelerator()
   m_iHaveSeenCount = 0
   Erase m_hMenuSeen()
End Sub

Private Sub Class_Initialize()
   Set m_cNCM = New cNCMetrics
   m_cNCM.GetMetrics
   Set m_cMemDC = New cMemDC
   m_cMemDC.Width = Screen.Width \ Screen.TwipsPerPixelY
   m_cMemDC.Height = 24
   m_oActiveMenuColor = CLR_INVALID
   m_oInActiveMenuColor = CLR_INVALID
   m_oMenuBackgroundColor = CLR_INVALID
   Set m_fntSymbol = New StdFont
   m_fntSymbol.Name = "Marlett"
   m_fntSymbol.Size = Font.Size * 1.2
   Set m_cBrush = New cDottedBrush
   m_cBrush.Create
End Sub

Private Sub Class_Terminate()
   Set m_cMemDC = Nothing
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
   '
End Property

Private Property Get ISubclass_MsgResponse() As EMsgResponse
   If _
      CurrentMessage = WM_DESTROY Or _
      CurrentMessage = WM_INITMENUPOPUP Or _
      CurrentMessage = WM_WININICHANGE Or _
      CurrentMessage = WM_EXITMENULOOP _
   Then
      ISubclass_MsgResponse = emrPreprocess
   Else
      ISubclass_MsgResponse = emrConsume
   End If
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long,
 ByVal wParam As Long, ByVal lParam As Long) As Long
Dim iMenu As Long
Dim iLastDownOn As Long
Dim iLastOver As Long
Dim lR As Long
Dim lFlag As Long
Dim hMenu As Long
Dim iChar As Long

   Select Case iMsg
   Case WM_INITMENUPOPUP
      If (lParam And &HFFFF0000) = 0 Then
         OwnerDrawMenu wParam
      End If
      
   Case WM_MEASUREITEM
      ISubclass_WindowProc = MeasureItem(wParam, lParam)
   
   Case WM_DRAWITEM
      DrawItem wParam, lParam
      
   Case WM_MENUCHAR
      ' Check that this is my menu:
      lFlag = wParam \ &H10000
      If ((lFlag And MF_SYSMENU) <> MF_SYSMENU) Then
         hMenu = lParam
         iChar = (wParam And &HFFFF&)
         ' See if this corresponds to an accelerator on the menu:
         lR = ParseMenuChar(hMenu, iChar)
         If lR > 0 Then
            ISubclass_WindowProc = lR
            Exit Function
         End If
      End If
      ISubclass_WindowProc = CallOldWindowProc(m_hWnd, WM_MENUCHAR, wParam,
       lParam)
   
   Case WM_WININICHANGE
      m_cNCM.GetMetrics
   
   Case WM_EXITMENULOOP
      pRestoreList
   
   Case WM_DESTROY
      Detach
   
   End Select
   
End Function
Private Function ParseMenuChar( _
        ByVal hMenu As Long, _
        ByVal iChar As Integer _
    ) As Long
Dim sChar As String
Dim l As Long
Dim lH() As Long
Dim sItems() As String
    
    sChar = UCase$(Chr$(iChar))
    For l = 1 To m_iRestore
        If (m_hMenuRestore(l) = hMenu) Then
            If (m_sAccelerator(l) = sChar) Then
               ParseMenuChar = &H20000 Or m_iMenuPosition(l)
               ' Debug.Print "Found Menu Char"
               Exit Function
            End If
        End If
    Next l
    
End Function

Private Function MeasureItem(ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tMIS As MEASUREITEMSTRUCT
Dim lID As Long
   
   CopyMemory tMIS, ByVal lParam, LenB(tMIS)
   If tMIS.CtlType = ODT_MENU Then
                  
      ' because we don't get the popup menu handle
      ' in the tMIS structure, we have to do an internal
      ' lookup to find info about this menu item.
      ' poor implementation of MEASUREITEMSTRUCT - it
      ' should have a .hWndItem field like DRAWITEMSTRUCT
      ' - spm
      lID = InternalIDForWindowsID(tMIS.itemID)
            
      ' Width:
      tMIS.itemWidth = 4 + 22 + m_lMenuTextSize(lID) + 4
      If m_lMenuShortCutSize(lID) > 0 Then
         tMIS.itemWidth = tMIS.itemWidth + 4 + m_lMenuShortCutSize(lID) + 4
      End If
      If (m_OfficeXPStyle) Then
         tMIS.itemWidth = tMIS.itemWidth + 4
      End If
      
      ' Height:
      If lID > 0 And lID <= m_iRestore Then
         If (m_tMIIS(lID).fType And MFT_SEPARATOR) = MFT_SEPARATOR Then
            If (m_OfficeXPStyle) Then
               tMIS.itemHeight = 3
            Else
               tMIS.itemHeight = 8
            End If
         Else
            ' menu item height is always the same
            tMIS.itemHeight = m_lMenuItemHeight + 6
            If (m_OfficeXPStyle) Then
               tMIS.itemHeight = tMIS.itemHeight + 4
            End If
         End If
      Else
         ' problem.
      End If
      
      CopyMemory ByVal lParam, tMIS, LenB(tMIS)
      
   Else
      MeasureItem = CallOldWindowProc(m_hWnd, WM_MEASUREITEM, wParam, lParam)
   End If
End Function
Private Function DrawItem(ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tDIS As DRAWITEMSTRUCT
Dim hBr As Long
Dim tR As RECT, tTR As RECT, tWR As RECT
Dim lHDC As Long
Dim hFntOld As Long
Dim hFntsOld As Long
Dim tMII As MENUITEMINFO
Dim bRadioCheck As Boolean, bDisabled As Boolean, bChecked As Boolean,
 bHighlighted As Boolean
Dim bIsTopLevel As Boolean
Dim lID As Long
Dim lSelLeft As Long
Dim sCC As String
Dim lIconIndex As Long
Dim lX As Long, lY As Long
Dim hBrush As Long

   CopyMemory tDIS, ByVal lParam, LenB(tDIS)
   
   If tDIS.CtlType = ODT_MENU Then
      ' tDIS.hWndItem is the menu containing the item, tDIS.itemID is the wID
      
      m_cMemDC.Width = tDIS.rcItem.right - tDIS.rcItem.left + 1
      m_cMemDC.Height = tDIS.rcItem.bottom - tDIS.rcItem.top + 1
      lHDC = m_cMemDC.hdc
      hFntOld = SelectObject(lHDC, hFont)
      
      LSet tR = tDIS.rcItem
      OffsetRect tR, -tR.left, -tR.top
            
      ' Fill background:
      tTR.right = m_cMemDC.Width
      tTR.bottom = m_cMemDC.Height
      
      If m_cBitmap Is Nothing Then
         hBr = CreateSolidBrush(TranslateColor(MenuBackgroundColor))
         FillRect lHDC, tTR, hBr
         DeleteObject hBr
      Else
         TileArea lHDC, tR.left, tR.top, tR.right - tR.left + 1, tR.bottom -
          tR.top + 1, m_cBitmap.hdc, m_cBitmap.Width, m_cBitmap.Height,
          tDIS.rcItem.top
      End If
         
      If (m_OfficeXPStyle) Then
         Dim tSideRect As RECT
         LSet tSideRect = tTR
         tSideRect.right = m_lMenuItemHeight + 8
         fillWithLighterControlColour lHDC, tSideRect, tDIS.rcItem.top
      End If
      
      tR.top = tR.top + 1
            
      SetBkMode lHDC, TRANSPARENT
      
      ' Draw the text:
      tMII.cbSize = LenB(tMII)
      tMII.fMask = MIIM_TYPE Or MIIM_STATE Or MIIM_DATA
      ReDim b(0 To 128) As Byte
      tMII.dwTypeData = VarPtr(b(0))
      GetMenuItemInfo tDIS.hwndItem, tDIS.itemID, False, tMII
      
      If (tMII.fType And MFT_SEPARATOR) = MFT_SEPARATOR Then
         ' Separator:
         LSet tWR = tR
         tWR.top = (tWR.bottom - tWR.top - 2) \ 2 + tWR.top
         tWR.bottom = tWR.top + 2
         InflateRect tWR, -12, 0
         If (m_OfficeXPStyle) Then
            Dim tWRS As RECT
            LSet tWRS = tWR
            tWRS.left = tSideRect.right + 4
            tWRS.right = tWRS.right + 20
            tWRS.top = tWRS.top + 1
            tWRS.bottom = tWRS.top
            DrawEdge lHDC, tWRS, BDR_SUNKENOUTER, BF_TOP Or BF_BOTTOM, True
         Else
            DrawEdge lHDC, tWR, BDR_SUNKENOUTER, BF_TOP Or BF_BOTTOM, False
         End If
      Else
         ' Text item:
         bRadioCheck = ((tMII.fType And MFT_RADIOCHECK) = MFT_RADIOCHECK)
         bDisabled = ((tMII.fState And MFS_DISABLED) = MFS_DISABLED)
         bChecked = ((tMII.fState And MFS_CHECKED) = MFS_CHECKED)
         bHighlighted = ((tMII.fState And MFS_HILITE) = MFS_HILITE)
         
         lID = tMII.dwItemData

         ' Icon?
         lIconIndex = -1
         On Error Resume Next
         lIconIndex = m_colIcons.Item(m_sCaption(lID))
         On Error GoTo 0
         
         If bChecked Or lIconIndex > -1 Then
            lSelLeft = 4 + (tR.bottom - tR.top + 1 - 4)
         End If
                           
         If bHighlighted And Not bDisabled Then
            If m_eHighlightStyle = ECPHighlightStyleGradient Then
               ' Draw a gradient:
               LSet tWR = tR
               tWR.left = lSelLeft
               tWR.right = tWR.left + 4 + (tR.bottom - tR.top + 1 - 4)
               hBr = CreateSolidBrush(TranslateColor(vbHighlight))
               FillRect lHDC, tWR, hBr
               DeleteObject hBr
               LSet tWR = tR
               tWR.left = tWR.left + 4 + (tR.bottom - tR.top + 1 - 4)
               DrawGradient lHDC, tWR, TranslateColor(vbHighlight),
                TranslateColor(MenuBackgroundColor), False
            ElseIf m_eHighlightStyle = ECPHighlightStyleButton Then
               ' do nothing now
            Else
               ' standard:
               If (m_OfficeXPStyle) Then
                  LSet tWR = tR
                  tWR.left = tWR.left + 1
                  tWR.right = tWR.right - 2
                  fillWithLighterSelectedColour lHDC, tWR, tDIS.rcItem.top +
                   tWR.top
                  DrawEdge lHDC, tWR, 0, 0, True
               Else
                  LSet tWR = tR
                  tWR.left = lSelLeft
                  fillWithHighlightBackColor lHDC, tWR, tDIS.rcItem.top +
                   tWR.top
               End If
            End If
         End If
         
         If bDisabled Then
            SetTextColor lHDC, TranslateColor(vb3DHighlight)
         Else
            If bHighlighted Then
               SetTextColor lHDC, TranslateColor(ActiveMenuForeColor)
            Else
               SetTextColor lHDC, TranslateColor(InActiveMenuForeColor)
            End If
         End If
         
         ' Get the check/icon space:
         LSet tWR = tR
         If m_eHighlightStyle = ECPHighlightStyleButton Then
            InflateRect tWR, -2, -2
         Else
            tWR.left = tWR.left + 1
         End If
         tWR.right = tWR.left + (tWR.bottom - tWR.top + 1 - 2)
         
         ' Check:
         If bChecked Then
                        
            ' Colour in:
            If Not bHighlighted Then
               SetBkMode lHDC, OPAQUE
               If (m_OfficeXPStyle) Then
                  LSet tWRS = tWR
                  InflateRect tWRS, -1, -1
                  hBrush = CreateSolidBrush(BlendColor(vbHighlight,
                   BlendColor(MenuBackgroundColor, vbButtonFace, 128), 40))
                  FillRect lHDC, tWRS, hBrush
                  DeleteObject hBrush
               Else
                  If (NoPalette) Then
                     hBrush =
                      CreateSolidBrush(LighterColour(MenuBackgroundColor))
                     FillRect lHDC, tWR, hBrush
                     DeleteObject hBrush
                  Else
                     m_cBrush.Rectangle lHDC, tWR.left, tWR.top, tWR.right -
                      tWR.left, tWR.bottom - tWR.top, 1, PATCOPY, True,
                      MenuBackgroundColor, vb3DHighlight
                  End If
               End If
               SetBkMode lHDC, TRANSPARENT
                  
               If bDisabled Then
                  SetTextColor lHDC, TranslateColor(vb3DHighlight)
               End If
            ElseIf (m_OfficeXPStyle) Then
               LSet tWRS = tWR
               InflateRect tWRS, -1, -1
               hBrush = CreateSolidBrush(BlendColor(vbHighlight,
                MenuBackgroundColor, 128))
               FillRect lHDC, tWRS, hBrush
               DeleteObject hBrush
            End If
            If Not bDisabled Then
               If bHighlighted Then
                  SetTextColor lHDC, TranslateColor(ActiveMenuForeColor)
               Else
                  SetTextColor lHDC, TranslateColor(InActiveMenuForeColor)
               End If
            End If
            
            If (m_OfficeXPStyle) Then
               LSet tWRS = tWR
               InflateRect tWRS, -1, -1
               DrawEdge lHDC, tWRS, BDR_SUNKENOUTER, BF_RECT, m_OfficeXPStyle
            Else
               DrawEdge lHDC, tWR, BDR_SUNKENOUTER, BF_RECT, m_OfficeXPStyle
            End If
                        
            If lIconIndex = -1 Then
               ' Draw the appropriate symbol:
               SelectObject lHDC, hFntOld
               hFntsOld = SelectObject(lHDC, hFontSymbol)
               If bHighlighted Then
                  SetTextColor lHDC, TranslateColor(InActiveMenuForeColor)
               End If
               If bRadioCheck Then
                  pDrawText lHDC, "h", tWR, DT_VCENTER Or DT_CENTER Or
                   DT_SINGLELINE, bDisabled
               Else
                  pDrawText lHDC, "b", tWR, DT_VCENTER Or DT_CENTER Or
                   DT_SINGLELINE, bDisabled
               End If
               SelectObject lHDC, hFntsOld
               hFntOld = SelectObject(lHDC, hFont)
               If bHighlighted Then
                  SetTextColor lHDC, TranslateColor(ActiveMenuForeColor)
               End If
            Else
               lX = tWR.left + (tWR.right - tWR.left + 1 - m_lIconSize) \ 2
               lY = tWR.top + (tWR.bottom - tWR.top + 1 - m_lIconSize) \ 2
               If bDisabled Then
                  ImageListDrawIconDisabled m_ptrVb6ImageList, lHDC, m_hIml,
                   lIconIndex, lX, lY, m_lIconSize
               Else
                  ImageListDrawIcon m_ptrVb6ImageList, lHDC, m_hIml,
                   lIconIndex, lX, lY
               End If
            End If
         Else
            If lIconIndex > -1 Then
               If bHighlighted And Not bDisabled Then
                  If (Not (m_eHighlightStyle = ECPHighlightStyleButton) And Not
                   (m_OfficeXPStyle)) Then
                     DrawEdge lHDC, tWR, BDR_RAISEDINNER, BF_RECT,
                      m_OfficeXPStyle
                  End If
               End If
               lX = tWR.left + (tWR.right - tWR.left + 1 - m_lIconSize) \ 2
               lY = tWR.top + (tWR.bottom - tWR.top + 1 - m_lIconSize) \ 2
               lX = lX + 2 * Abs(m_eHighlightStyle = ECPHighlightStyleButton)
               If bDisabled Then
                  ImageListDrawIconDisabled m_ptrVb6ImageList, lHDC, m_hIml,
                   lIconIndex, lX, lY, m_lIconSize
               Else
                  If (m_OfficeXPStyle) Then
                     If (bHighlighted) Then
                        ImageListDrawIconDisabled m_ptrVb6ImageList, lHDC,
                         m_hIml, lIconIndex, lX + 1, lY + 1, m_lIconSize, True
                        ImageListDrawIcon m_ptrVb6ImageList, lHDC, m_hIml,
                         lIconIndex, lX - 1, lY - 1
                     Else
                        ImageListDrawIcon m_ptrVb6ImageList, lHDC, m_hIml,
                         lIconIndex, lX, lY
                     End If
                  Else
                     ImageListDrawIcon m_ptrVb6ImageList, lHDC, m_hIml,
                      lIconIndex, lX, lY
                  End If
               End If
            End If

         End If
         
                  
         ' Draw text:
         If m_eHighlightStyle = ECPHighlightStyleButton And Not (bDisabled) Then
            SetTextColor lHDC, TranslateColor(InActiveMenuForeColor)
         End If
         
         LSet tWR = tR
         tWR.left = 4 + (tR.bottom - tR.top + 1 - 4) + 2
         If (m_OfficeXPStyle) Then
            tWR.left = tWR.left + 4
         End If
         If lID > 0 And lID <= m_iRestore Then
            pDrawText lHDC, m_sCaption(lID), tWR, DT_LEFT Or DT_SINGLELINE Or
             DT_VCENTER, bDisabled
            If Len(m_sShortCut(lID)) > 0 Then
               tWR.left = tWR.left + m_lMenuTextSize(lID) + 4 + 4
               pDrawText lHDC, m_sShortCut(lID), tWR, DT_LEFT Or DT_SINGLELINE
                Or DT_VCENTER, bDisabled
            End If
         End If
         
         ' Highlighted:
         If bHighlighted And m_eHighlightStyle = ECPHighlightStyleButton And
          Not (bDisabled) Then
            LSet tWR = tR
            InflateRect tWR, -2, 0
            DrawEdge lHDC, tWR, BDR_RAISEDINNER, BF_RECT, m_OfficeXPStyle
         End If
         
      End If
      
      SelectObject lHDC, hFntOld
      
      BitBlt tDIS.hdc, tDIS.rcItem.left, tDIS.rcItem.top, tDIS.rcItem.right -
       tDIS.rcItem.left + 1, tDIS.rcItem.bottom - tDIS.rcItem.top + 1, lHDC, 0,
       0, vbSrcCopy
      
   Else
      DrawItem = CallOldWindowProc(m_hWnd, WM_DRAWITEM, wParam, lParam)
   End If
   
End Function
Private Function pDrawText(ByVal lHDC As Long, ByVal sText As String, tR As
 RECT, ByVal dtFlags As Long, ByVal bDisabled As Boolean)
Dim tWR As RECT
   LSet tWR = tR
   If bDisabled Then
      If (m_OfficeXPStyle) Then
         SetTextColor lHDC, TranslateColor(vb3DShadow)
      Else
         SetTextColor lHDC, TranslateColor(vb3DHighlight)
         OffsetRect tWR, 1, 1
      End If
   End If
   DrawText lHDC, sText, -1, tWR, dtFlags
   If bDisabled Then
      If Not (m_OfficeXPStyle) Then
         SetTextColor lHDC, TranslateColor(vbButtonShadow)
         OffsetRect tWR, -1, -1
         DrawText lHDC, sText, -1, tWR, dtFlags
      End If
   End If
End Function

Private Sub DrawGradient( _
      ByVal hdc As Long, _
      ByRef rct As RECT, _
      ByVal lEndColour As Long, _
      ByVal lStartColour As Long, _
      ByVal bVertical As Boolean _
   )
Dim lStep As Long
Dim lPos As Long, lSize As Long
Dim bRGB(1 To 3) As Integer
Dim bRGBStart(1 To 3) As Integer
Dim dR(1 To 3) As Double
Dim dPos As Double, d As Double
Dim hBr As Long
Dim tR As RECT
   
   LSet tR = rct
   If bVertical Then
      lSize = (tR.bottom - tR.top)
   Else
      lSize = (tR.right - tR.left)
   End If
   lStep = lSize \ 255
   If (lStep < 3) Then
       lStep = 3
   End If
       
   bRGB(1) = lStartColour And &HFF&
   bRGB(2) = (lStartColour And &HFF00&) \ &H100&
   bRGB(3) = (lStartColour And &HFF0000) \ &H10000
   bRGBStart(1) = bRGB(1): bRGBStart(2) = bRGB(2): bRGBStart(3) = bRGB(3)
   dR(1) = (lEndColour And &HFF&) - bRGB(1)
   dR(2) = ((lEndColour And &HFF00&) \ &H100&) - bRGB(2)
   dR(3) = ((lEndColour And &HFF0000) \ &H10000) - bRGB(3)
        
   For lPos = lSize To 0 Step -lStep
      ' Draw bar:
      If bVertical Then
         tR.top = tR.bottom - lStep
      Else
         tR.left = tR.right - lStep
      End If
      If tR.top < rct.top Then
         tR.top = rct.top
      End If
      If tR.left < rct.left Then
         tR.left = rct.left
      End If
      
      'Debug.Print tR.Right, tR.left, (bRGB(3) * &H10000 + bRGB(2) * &H100& +
       bRGB(1))
      hBr = CreateSolidBrush((bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1)))
      FillRect hdc, tR, hBr
      DeleteObject hBr
            
      ' Adjust colour:
      dPos = ((lSize - lPos) / lSize)
      If bVertical Then
         tR.bottom = tR.top
         bRGB(1) = bRGBStart(1) + dR(1) * dPos
         bRGB(2) = bRGBStart(2) + dR(2) * dPos
         bRGB(3) = bRGBStart(3) + dR(3) * dPos
      Else
         tR.right = tR.left
         bRGB(1) = bRGBStart(1) + dR(1) * dPos
         bRGB(2) = bRGBStart(2) + dR(2) * dPos
         bRGB(3) = bRGBStart(3) + dR(3) * dPos
      End If
      
   Next lPos

End Sub

Private Sub TileArea( _
        ByVal hdcTo As Long, _
        ByVal x As Long, _
        ByVal y As Long, _
        ByVal Width As Long, _
        ByVal Height As Long, _
        ByVal hDcSrc As Long, _
        ByVal SrcWidth As Long, _
        ByVal SrcHeight As Long, _
        ByVal lOffsetY As Long _
    )
Dim lSrcX As Long
Dim lSrcY As Long
Dim lSrcStartX As Long
Dim lSrcStartY As Long
Dim lSrcStartWidth As Long
Dim lSrcStartHeight As Long
Dim lDstX As Long
Dim lDstY As Long
Dim lDstWidth As Long
Dim lDstHeight As Long

    lSrcStartX = (x Mod SrcWidth)
    lSrcStartY = ((y + lOffsetY) Mod SrcHeight)
    lSrcStartWidth = (SrcWidth - lSrcStartX)
    lSrcStartHeight = (SrcHeight - lSrcStartY)
    lSrcX = lSrcStartX
    lSrcY = lSrcStartY
    
    lDstY = y
    lDstHeight = lSrcStartHeight
    
    Do While lDstY < (y + Height)
        If (lDstY + lDstHeight) > (y + Height) Then
            lDstHeight = y + Height - lDstY
        End If
        lDstWidth = lSrcStartWidth
        lDstX = x
        lSrcX = lSrcStartX
        Do While lDstX < (x + Width)
            If (lDstX + lDstWidth) > (x + Width) Then
                lDstWidth = x + Width - lDstX
                If (lDstWidth = 0) Then
                    lDstWidth = 4
                End If
            End If
            'If (lDstWidth > Width) Then lDstWidth = Width
            'If (lDstHeight > Height) Then lDstHeight = Height
            BitBlt hdcTo, lDstX, lDstY, lDstWidth, lDstHeight, hDcSrc, lSrcX,
             lSrcY, vbSrcCopy
            lDstX = lDstX + lDstWidth
            lSrcX = 0
            lDstWidth = SrcWidth
        Loop
        lDstY = lDstY + lDstHeight
        lSrcY = 0
        lDstHeight = SrcHeight
    Loop
End Sub

' Convert Automation color to Windows color
Private Function TranslateColor(ByVal clr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    If OleTranslateColor(clr, hPal, TranslateColor) Then
        TranslateColor = CLR_INVALID
    End If
End Function

Private Property Get ObjectFromPtr(ByVal lPtr As Long) As Object
Dim oTemp As Object
   ' Turn the pointer into an illegal, uncounted interface
   CopyMemory oTemp, lPtr, 4
   ' Do NOT hit the End button here! You will crash!
   ' Assign to legal reference
   Set ObjectFromPtr = oTemp
   ' Still do NOT hit the End button here! You will still crash!
   ' Destroy the illegal reference
   CopyMemory oTemp, 0&, 4
   ' OK, hit the End button if you must--you'll probably still crash,
   ' but it will be because of the subclass, not the uncounted reference
End Property


Private Function DrawEdge( _
      ByVal hdc As Long, _
      qrc As RECT, _
      ByVal edge As Long, _
      ByVal grfFlags As Long, _
      ByVal bOfficeXpStyle As Boolean _
   ) As Long
   If (bOfficeXpStyle) Then
      Dim junk As POINTAPI
      Dim hPenOld As Long
      Dim hPen As Long
      If (qrc.bottom > qrc.top) Then
         hPen = CreatePen(PS_SOLID, 1, TranslateColor(vbHighlight))
      Else
         hPen = CreatePen(PS_SOLID, 1, TranslateColor(vb3DShadow))
      End If
      hPenOld = SelectObject(hdc, hPen)
      MoveToEx hdc, qrc.left, qrc.top, junk
      LineTo hdc, qrc.right - 1, qrc.top
      If (qrc.bottom > qrc.top) Then
         LineTo hdc, qrc.right - 1, qrc.bottom - 1
         LineTo hdc, qrc.left, qrc.bottom - 1
         LineTo hdc, qrc.left, qrc.top
      End If
      SelectObject hdc, hPenOld
      DeleteObject hPen
   Else
      DrawEdgeAPI hdc, qrc, edge, grfFlags
   End If
End Function


Private Sub ImageListDrawIcon( _
        ByVal ptrVb6ImageList As Long, _
        ByVal hdc As Long, _
        ByVal hIml As Long, _
        ByVal iIconIndex As Long, _
        ByVal lX As Long, _
        ByVal lY As Long, _
        Optional ByVal bSelected As Boolean = False, _
        Optional ByVal bBlend25 As Boolean = False _
    )
Dim lFlags As Long
Dim lR As Long

    lFlags = ILD_TRANSPARENT
    If (bSelected) Then
        lFlags = lFlags Or ILD_SELECTED
    End If
    If (bBlend25) Then
        lFlags = lFlags Or ILD_BLEND25
    End If
    If (ptrVb6ImageList <> 0) Then
        Dim o As Object
        On Error Resume Next
        Set o = ObjectFromPtr(ptrVb6ImageList)
        If Not (o Is Nothing) Then
            o.ListImages(iIconIndex + 1).Draw hdc, lX * Screen.TwipsPerPixelX,
             lY * Screen.TwipsPerPixelY, lFlags
        End If
        On Error GoTo 0
    Else
        lR = ImageList_Draw( _
                hIml, _
                iIconIndex, _
                hdc, _
                lX, _
                lY, _
                lFlags)
        If (lR = 0) Then
            Debug.Print "Failed to draw Image: " & iIconIndex & " onto hDC " &
             hdc, "ImageListDrawIcon"
        End If
    End If
End Sub
Private Sub ImageListDrawIconDisabled( _
        ByVal ptrVb6ImageList As Long, _
        ByVal hdc As Long, _
        ByVal hIml As Long, _
        ByVal iIconIndex As Long, _
        ByVal lX As Long, _
        ByVal lY As Long, _
        ByVal lSize As Long, _
        Optional ByVal asShadow As Boolean _
    )
Dim lR As Long
Dim hIcon As Long

   hIcon = 0
   If (ptrVb6ImageList <> 0) Then
      Dim o As Object
      On Error Resume Next
      Set o = ObjectFromPtr(ptrVb6ImageList)
      If Not (o Is Nothing) Then
         
         Dim lhDCDisp As Long
         Dim lHDC As Long
         Dim lhBmp As Long
         Dim lhBmpOld As Long
         Dim lhIml As Long
                  
         lhDCDisp = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
         lHDC = CreateCompatibleDC(lhDCDisp)
         lhBmp = CreateCompatibleBitmap(lhDCDisp, o.ImageWidth, o.ImageHeight)
         DeleteDC lhDCDisp
         lhBmpOld = SelectObject(lHDC, lhBmp)
         o.ListImages.Item(iIconIndex + 1).Draw lHDC, 0, 0, 0
         SelectObject lHDC, lhBmpOld
         DeleteDC lHDC
         lhIml = ImageList_Create(o.ImageWidth, o.ImageHeight, ILC_MASK Or
          ILC_COLOR32, 1, 1)
         ImageList_AddMasked lhIml, lhBmp, TranslateColor(o.BackColor)
         DeleteObject lhBmp
         hIcon = ImageList_GetIcon(lhIml, 0, 0)
         ImageList_Destroy lhIml
         
      End If
      On Error GoTo 0
   Else
      hIcon = ImageList_GetIcon(hIml, iIconIndex, 0)
   End If
   If (hIcon <> 0) Then
      If (asShadow) Then
         Dim hBr As Long
         hBr = GetSysColorBrush(vb3DShadow And &H1F)
         lR = DrawState(hdc, hBr, 0, hIcon, 0, lX, lY, lSize, lSize, DST_ICON
          Or DSS_MONO)
         DeleteObject hBr
      Else
         lR = DrawState(hdc, 0, 0, hIcon, 0, lX, lY, lSize, lSize, DST_ICON Or
          DSS_DISABLED)
      End If
      DestroyIcon hIcon
   End If
   
End Sub
Private Sub fillWithLighterBackColor(ByVal lHDC As Long, tR As RECT, ByVal
 lOffsetY As Long, ByVal bInfrequent As Boolean)
Dim hBrush As Long
   SetBkMode lHDC, OPAQUE
   If (NoPalette) Then
      If bInfrequent Then
         hBrush = CreateSolidBrush(SlightlyLighterColour(MenuBackgroundColor))
      Else
         hBrush = CreateSolidBrush(LighterColour(MenuBackgroundColor))
      End If
      FillRect lHDC, tR, hBrush
      DeleteObject hBrush
   Else
      m_cBrush.Rectangle lHDC, tR.left, tR.top, tR.right - tR.left + 1,
       tR.bottom - tR.top + 1, 1, PATCOPY, True, MenuBackgroundColor,
       vb3DHighlight
   End If
   SetBkMode lHDC, TRANSPARENT
End Sub
Private Sub fillWithHighlightBackColor(ByVal lHDC As Long, tR As RECT, ByVal
 lOffsetY As Long)
Dim hBr As Long
   hBr = CreateSolidBrush(TranslateColor(vbHighlight))
   FillRect lHDC, tR, hBr
   DeleteObject hBr
End Sub
Private Sub fillWithNormalBackground(ByVal lHDC As Long, tR As RECT, ByVal
 lOffsetY As Long)
Dim hBrush As Long
   hBrush = CreateSolidBrush(TranslateColor(MenuBackgroundColor))
   FillRect lHDC, tR, hBrush
   DeleteObject hBrush
End Sub
Private Sub fillWithLighterControlColour(ByVal lHDC As Long, tR As RECT, ByVal
 lOffsetY As Long)

Dim hBrush As Long
   SetBkMode lHDC, OPAQUE
   If (NoPalette) Then
      hBrush = CreateSolidBrush(BlendColor(MenuBackgroundColor, vbButtonFace,
       128))
      FillRect lHDC, tR, hBrush
      DeleteObject hBrush
   Else
      m_cBrush.Rectangle lHDC, tR.left, tR.top, tR.right - tR.left + 1,
       tR.bottom - tR.top + 1, 1, PATCOPY, True, MenuBackgroundColor,
       vb3DHighlight
   End If
   SetBkMode lHDC, TRANSPARENT
End Sub

Private Sub fillWithLighterSelectedColour(ByVal lHDC As Long, tR As RECT, ByVal
 lOffsetY As Long)

Dim hBrush As Long
   SetBkMode lHDC, OPAQUE
   If (NoPalette) Then
      hBrush = CreateSolidBrush(BlendColor(vbHighlight, MenuBackgroundColor,
       80))
      FillRect lHDC, tR, hBrush
      DeleteObject hBrush
   Else
      m_cBrush.Rectangle lHDC, tR.left, tR.top, tR.right - tR.left + 1,
       tR.bottom - tR.top + 1, 1, PATCOPY, True, MenuBackgroundColor,
       vb3DHighlight
   End If
   SetBkMode lHDC, TRANSPARENT
End Sub
Private Property Get BlendColor( _
      ByVal oColorFrom As OLE_COLOR, _
      ByVal oColorTo As OLE_COLOR, _
      Optional ByVal alpha As Long = 128 _
   ) As Long
Dim lCFrom As Long
Dim lCTo As Long
   lCFrom = TranslateColor(oColorFrom)
   lCTo = TranslateColor(oColorTo)
Dim lSrcR As Long
Dim lSrcG As Long
Dim lSrcB As Long
Dim lDstR As Long
Dim lDstG As Long
Dim lDstB As Long
   lSrcR = lCFrom And &HFF
   lSrcG = (lCFrom And &HFF00&) \ &H100&
   lSrcB = (lCFrom And &HFF0000) \ &H10000
   lDstR = lCTo And &HFF
   lDstG = (lCTo And &HFF00&) \ &H100&
   lDstB = (lCTo And &HFF0000) \ &H10000
     
   
   BlendColor = RGB( _
      ((lSrcR * alpha) / 255) + ((lDstR * (255 - alpha)) / 255), _
      ((lSrcG * alpha) / 255) + ((lDstG * (255 - alpha)) / 255), _
      ((lSrcB * alpha) / 255) + ((lDstB * (255 - alpha)) / 255) _
      )
      
End Property
Private Property Get SlightlyLighterColour(ByVal oColor As OLE_COLOR) As Long
Dim lC As Long
Dim h As Single, s As Single, l As Single
Dim lR As Long, lG As Long, lB As Long
Static s_lColLast As Long
Static s_lLightColLast As Long
   
   lC = TranslateColor(oColor)
   If (lC <> s_lColLast) Then
      s_lColLast = lC
      RGBToHLS lC And &HFF&, (lC \ &H100) And &HFF&, (lC \ &H10000) And &HFF&,
       h, s, l
      If (l > 0.99) Then
         l = l * 0.95
      Else
         l = l * 1.05
         If (l > 1) Then
            l = 1
         End If
      End If
      HLSToRGB h, s, l, lR, lG, lB
      s_lLightColLast = RGB(lR, lG, lB)
   End If
   SlightlyLighterColour = s_lLightColLast
End Property

Private Property Get LighterColour(ByVal oColor As OLE_COLOR) As Long
Dim lC As Long
Dim h As Single, s As Single, l As Single
Dim lR As Long, lG As Long, lB As Long
Static s_lColLast As Long
Static s_lLightColLast As Long
   
   lC = TranslateColor(oColor)
   If (lC <> s_lColLast) Then
      s_lColLast = lC
      RGBToHLS lC And &HFF&, (lC \ &H100) And &HFF&, (lC \ &H10000) And &HFF&,
       h, s, l
      If (l > 0.99) Then
         l = l * 0.8
      Else
         l = l * 1.2
         If (l > 1) Then
            l = 1
         End If
      End If
      HLSToRGB h, s, l, lR, lG, lB
      s_lLightColLast = RGB(lR, lG, lB)
   End If
   LighterColour = s_lLightColLast
End Property
 
Private Property Get NoPalette(Optional ByVal bForce As Boolean = False) As
 Boolean
Static bOnce As Boolean
Static bNoPalette As Boolean
Dim lHDC As Long
Dim lBits As Long
   If (bForce) Then
      bOnce = False
   End If
   If Not (bOnce) Then
      lHDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
      If (lHDC <> 0) Then
         lBits = GetDeviceCaps(lHDC, BITSPIXEL)
         If (lBits <> 0) Then
            bOnce = True
         End If
         bNoPalette = (lBits > 8)
         DeleteDC lHDC
      End If
   End If
   NoPalette = bNoPalette
End Property

Private Sub RGBToHLS( _
     ByVal r As Long, ByVal g As Long, ByVal b As Long, _
     h As Single, s As Single, l As Single _
     )
 Dim Max As Single
 Dim Min As Single
 Dim delta As Single
 Dim rR As Single, rG As Single, rB As Single

     rR = r / 255: rG = g / 255: rB = b / 255

 '{Given: rgb each in [0,1].
 ' Desired: h in [0,360] and s in [0,1], except if s=0, then h=UNDEFINED.}
         Max = Maximum(rR, rG, rB)
         Min = Minimum(rR, rG, rB)
             l = (Max + Min) / 2 '{This is the lightness}
         '{Next calculate saturation}
         If Max = Min Then
             'begin {Acrhomatic case}
             s = 0
             h = 0
             'end {Acrhomatic case}
         Else
             'begin {Chromatic case}
                 '{First calculate the saturation.}
             If l <= 0.5 Then
                 s = (Max - Min) / (Max + Min)
             Else
                 s = (Max - Min) / (2 - Max - Min)
             End If
             '{Next calculate the hue.}
             delta = Max - Min
             If rR = Max Then
                     h = (rG - rB) / delta '{Resulting color is between yellow
                      and magenta}
             ElseIf rG = Max Then
                 h = 2 + (rB - rR) / delta '{Resulting color is between cyan
                  and yellow}
             ElseIf rB = Max Then
                 h = 4 + (rR - rG) / delta '{Resulting color is between magenta
                  and cyan}
             End If
         'end {Chromatic Case}
     End If
 End Sub

 Private Sub HLSToRGB( _
     ByVal h As Single, ByVal s As Single, ByVal l As Single, _
     r As Long, g As Long, b As Long _
     )
 Dim rR As Single, rG As Single, rB As Single
 Dim Min As Single, Max As Single

     If s = 0 Then
     ' Achromatic case:
     rR = l: rG = l: rB = l
     Else
     ' Chromatic case:
     ' delta = Max-Min
     If l <= 0.5 Then
         's = (Max - Min) / (Max + Min)
         ' Get Min value:
         Min = l * (1 - s)
     Else
         's = (Max - Min) / (2 - Max - Min)
         ' Get Min value:
         Min = l - s * (1 - l)
     End If
     ' Get the Max value:
     Max = 2 * l - Min
     
     ' Now depending on sector we can evaluate the h,l,s:
     If (h < 1) Then
         rR = Max
         If (h < 0) Then
             rG = Min
             rB = rG - h * (Max - Min)
         Else
             rB = Min
             rG = h * (Max - Min) + rB
         End If
     ElseIf (h < 3) Then
         rG = Max
         If (h < 2) Then
             rB = Min
             rR = rB - (h - 2) * (Max - Min)
         Else
             rR = Min
             rB = (h - 2) * (Max - Min) + rR
         End If
     Else
         rB = Max
         If (h < 4) Then
             rR = Min
             rG = rR - (h - 4) * (Max - Min)
         Else
             rG = Min
             rR = (h - 4) * (Max - Min) + rG
         End If
         
     End If
             
     End If
     r = rR * 255: g = rG * 255: b = rB * 255
 End Sub
 Private Function Maximum(rR As Single, rG As Single, rB As Single) As Single
     If (rR > rG) Then
     If (rR > rB) Then
         Maximum = rR
     Else
         Maximum = rB
     End If
     Else
     If (rB > rG) Then
         Maximum = rB
     Else
         Maximum = rG
     End If
     End If
 End Function
 Private Function Minimum(rR As Single, rG As Single, rB As Single) As Single
     If (rR < rG) Then
     If (rR < rB) Then
         Minimum = rR
     Else
         Minimum = rB
     End If
     Else
     If (rB < rG) Then
         Minimum = rB
     Else
         Minimum = rG
     End If
 End If
 End Function