vbAccelerator - Contents of code file: cOwnerDrawContextMenu.cls

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

'
 ===============================================================================
=======
'
' Name:     vbAccelerator Transparent Menu Demo
' Author:   Steve McMahon (steve@vbaccelerator.com)
' Date:     18 February 2001
'
' Requires: cNewMenu6.DLL
'           SSUBTMR6.DLL
'
' Copyright  1998-2001 Steve McMahon for vbAccelerator
'
'
 -------------------------------------------------------------------------------
-------
' Visit vbAccelerator - advanced free source code for VB programmers
' http://vbaccelerator.com
'
'
 -------------------------------------------------------------7-----------------
-------

Private Const WM_CONTEXTMENU = &H7B&
Private Const WM_DESTROY = &H2&

Public Event ContextMenu(ByVal Key As String, ByRef bDoDefault As Boolean)

Implements ISubclass

Private m_cP As cPopupMenu
Private Type tContextMenuItem
   sKey As String
   lhWnd As Long
   sPopupMenuKey As String
   bUseStoreRestore As Boolean
End Type
Private m_tItems() As tContextMenuItem
Private m_iItemCount As Long

Public Sub Add(ByVal Key As String, ByVal hWnd As Long, ByVal sMenuKey As
 String)
Dim lIndex As Long
   lIndex = plIndex(Key)
   If lIndex = 0 Then
      lIndex = plIndex(hWnd)
      If lIndex = 0 Then
         m_iItemCount = m_iItemCount + 1
         ReDim Preserve m_tItems(1 To m_iItemCount) As tContextMenuItem
         With m_tItems(m_iItemCount)
            .sKey = Key
            .lhWnd = hWnd
            .sPopupMenuKey = sMenuKey
         End With
         pSubClass m_tItems(m_iItemCount).lhWnd
      End If
   End If
End Sub
Public Property Get hWnd(ByVal Key As String) As Long
Dim lIndex As Long
   lIndex = plIndex(Key)
   If lIndex > 0 Then
      hWnd = m_tItems(lIndex).lhWnd
   End If
End Property
Public Property Let hWnd(ByVal Key As String, ByVal hWnd As Long)
Dim lIndex As Long
   lIndex = plIndex(Key)
   If lIndex > 0 Then
      pUnSubClass hWnd
      m_tItems(lIndex).lhWnd = hWnd
      pSubClass hWnd
   End If
End Property
Private Function plIndex(Key As Variant) As Long
Dim i As Long
   If VarType(Key) = vbString Then
      ' key search
      For i = 1 To m_iItemCount
         If m_tItems(i).sKey = Key Then
            plIndex = i
            Exit For
         End If
      Next i
   Else
      ' hwnd search
      For i = 1 To m_iItemCount
         If m_tItems(i).lhWnd = Key Then
            plIndex = i
            Exit For
         End If
      Next i
   End If
End Function

Public Sub Remove(ByVal Key As String)
Dim lIndex As Long
Dim i As Long
   lIndex = plIndex(Key)
   If lIndex > 0 Then
      pUnSubClass m_tItems(lIndex).lhWnd
      If m_iItemCount > 1 Then
         For i = lIndex To m_iItemCount - 1
            LSet m_tItems(i) = m_tItems(i + 1)
         Next i
         m_iItemCount = m_iItemCount + 1
         ReDim Preserve m_tItems(1 To m_iItemCount) As tContextMenuItem
      Else
         m_iItemCount = 0
      End If
   End If
End Sub
Public Property Let PopupMenu(cP As cPopupMenu)
   pSetMenu cP
End Property
Public Property Set PopupMenu(cP As cPopupMenu)
   pSetMenu cP
End Property
Private Sub pSetMenu(cP As cPopupMenu)
   Set m_cP = cP
End Sub
Private Sub pSubClass(ByVal hWnd As Long)
   AttachMessage Me, hWnd, WM_CONTEXTMENU
   AttachMessage Me, hWnd, WM_DESTROY
End Sub
Private Sub pUnSubClass(ByVal hWnd As Long)
   DetachMessage Me, hWnd, WM_CONTEXTMENU
   DetachMessage Me, hWnd, WM_DESTROY
End Sub
Private Sub pClearUp()
Dim i As Long
   For i = 1 To m_iItemCount
      pUnSubClass m_tItems(i).lhWnd
   Next i
   m_iItemCount = 0
   Set m_cP = Nothing
End Sub

Private Sub Class_Terminate()
   pClearUp
End Sub

Private Property Get LoWord(ByRef lThis As Long) As Long
   LoWord = (lThis And &HFFFF&)
End Property

Private Property Get HiWord(ByRef lThis As Long) As Long
   If (lThis And &H80000000) = &H80000000 Then
      HiWord = ((lThis And &H7FFF0000) \ &H10000) Or &H8000&
   Else
      HiWord = (lThis And &HFFFF0000) \ &H10000
   End If
End Property


Private Property Let ISubClass_MsgResponse(ByVal RHS As SSubTimer.EMsgResponse)
   '
End Property

Private Property Get ISubClass_MsgResponse() As SSubTimer.EMsgResponse
   ISubClass_MsgResponse = emrConsume
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 lR As Long
Dim lIndex As Long
Dim bDoDefault As Boolean
Dim lX As Long, lY As Long
   '
   Select Case iMsg
   Case WM_CONTEXTMENU
      Debug.Print "ContextMenu"
      
      On Error Resume Next
      lIndex = plIndex(hWnd)
      If Err.Number = 0 And lIndex > 0 Then
         RaiseEvent ContextMenu(m_tItems(lIndex).sKey, bDoDefault)
         
         lR = m_cP.IndexForKey(m_tItems(lIndex).sPopupMenuKey)
         If lR > 0 Then
            lX = LoWord(lParam)
            lY = HiWord(lParam)
            m_cP.ShowPopupAbsolute lX, lY, lR
         Else
            bDoDefault = True
         End If
      Else
         bDoDefault = True
      End If
      
      If bDoDefault Then
         ISubClass_WindowProc = CallOldWindowProc(hWnd, iMsg, wParam, lParam)
      End If
      
   Case WM_DESTROY
      lIndex = plIndex(hWnd)
      If lIndex > 0 Then
         On Error Resume Next
         Remove m_tItems(lIndex).sKey
      End If
   End Select
   '
End Function