Контекстное меню в виде объектов на форме - VB

Option Explicit
 
Private Type MENUINFO
   cbSize           As Long
   fMask            As Long
   dwStyle          As Long
   cyMax            As Long
   hbrBack          As Long
   dwContextHelpID  As Long
   dwMenuData       As Long
End Type
 
Private Declare Function SetMenuInfo Lib "user32.dll" (ByVal hmenu As Long, ByRef MENUINFO As MENUINFO) As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
 
Private Const WM_ENTERIDLE As Long = &H121
Private Const WM_MENUSELECT As Long = &H11F
Private Const WM_INITMENU As Long = &H116
Private Const WM_MENUDRAG = &H123
Private Const MIM_STYLE As Long = &H10
Private Const MNS_DRAGDROP = &H20000000
Private Const MF_MOUSESELECT As Long = &H8000&
Private Const MF_HILITE As Long = &H80&
 
Dim WithEvents oSub As clsTrickSubclass
 
Private Sub Form_Load()
    Dim mnu As Menu
    Dim idx As Long
    
    ' Создание динамического меню
    For idx = 0 To 10
        If idx Then Load mnuItem(idx)
        With mnuItem(idx)
            .Visible = True
            .caption = Choose(idx + 1, "Dinamic", "-", _
                                       "Moveable", "-", _
                                       "Menu", "-", _
                                       "Move", "-", _
                                       "Any", "Item", _
                                       "The trick")
        End With
    Next
    
    ' Включаем сабклассинг
    Set oSub = New clsTrickSubclass
    oSub.Hook hwnd
 
End Sub
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    ' Показываем меню при клике правой кнопкой мыши
    If Button = vbRightButton Then
        PopupMenu mnuContext
    End If
    
End Sub
 
Private Sub mnuItem_Click(Index As Integer)
    ' Пристанавливаем сабклассинг
    oSub.PauseSubclass
    ' Показываем пункт
    MsgBox mnuItem(Index).caption
    ' Возобновляем сабклассинг
    oSub.ResumeSubclass
End Sub
 
' Оконная процедура формы
Private Sub oSub_WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
    Static selMenu  As Long         ' Текущий выделенный пункт
    Static isDrag   As Boolean      ' Идет ли перетаскивание
    Static dragIdx  As Long         ' Перетаскиваемый пункт
    
    Select Case Msg
    
    ' При инициализации меню, инициализируем данные
    Case WM_INITMENU
        
        Dim info    As MENUINFO
        
        isDrag = False
        selMenu = -1
        dragIdx = -1
        
        ' Задаем стиль перетаскиваемого меню, так мы сможем контролировать видимость меню
        info.cbSize = Len(info)
        info.fMask = MIM_STYLE
        info.dwStyle = MNS_DRAGDROP
        
        ' Задаем
        SetMenuInfo wParam, info
    
    ' При выделении очередного пункта
    Case WM_MENUSELECT
    
        Dim flags As Long
        
        ' Получаем флаги
        flags = wParam \ &H10000
        
        ' Если пунт выделен не мышкой, то значит нам не нужно
        If (flags And MF_MOUSESELECT) = 0 Then DefCall = True: Exit Sub
        
        ' Если пункт подсвечен, то делаем его текущим
        If flags And MF_HILITE Then
            selMenu = wParam And &HFFFF&
        Else
        ' Разделители и недоступные пункты не помечаем
            selMenu = -1
        End If
        
        ' Если идет перетаскивание
        If isDrag Then
            ' Проверяем корректность пунктов для обмена
            If selMenu > 0 And dragIdx > 0 And selMenu <> dragIdx Then
                
                Dim mnu1 As Menu
                Dim mnu2 As Menu
                
                ' Преобразуем индексы меню
                If selMenu = 2 Then selMenu = 3
                If dragIdx = 2 Then dragIdx = 3
                
                ' Получаем объекты
                Set mnu1 = IndexToMenu(selMenu - 2)
                Set mnu2 = IndexToMenu(dragIdx - 2)
                
                ' Обмен
                Swap mnu1, mnu2
 
                ' Завершаем перетаскивание
                isDrag = False
                dragIdx = -1
                
            End If
        End If
    
    ' Для того чтобы получить возможность отследить нажатия из формы
    Case WM_ENTERIDLE
    
        ' Получаем состояние левой кнопки мыши
        If GetKeyState(vbKeyLButton) < 0 Then
            ' Нажата
            ' Если нет перетаскивания и пункт корректный, то начинаем перетаскивание этого пункта
            If (Not isDrag) And selMenu >= 0 Then
                isDrag = True
                dragIdx = selMenu
            End If
        ' Иначе отменяем перетаскивание
        Else: isDrag = False
        End If
    
    ' Возвращаем 0, чтобы не закрывалось меню при перетаскивании
    Case WM_MENUDRAG
        
        Ret = 0
        Exit Sub
        
    End Select
    
    ' Остальное нас не интересует
    DefCall = True
    
End Sub
 
' Обмен свойств пунктов меню
Private Sub Swap(mnu1 As Menu, mnu2 As Menu)
    Dim caption As String
    Dim checked As Boolean
    
    caption = mnu1.caption
    checked = mnu1.checked
    
    mnu1.caption = mnu2.caption
    mnu1.checked = mnu2.checked
    
    mnu2.caption = caption
    mnu2.checked = checked
End Sub
 
' Получить меню по индексу
Private Function IndexToMenu(ByVal Index As Long) As Menu
    Dim ctl As Object
    
    For Each ctl In Controls
        If TypeOf ctl Is Menu Then
            If Index = 0 Then Set IndexToMenu = ctl: Exit Function
            Index = Index - 1
        End If
    Next
End Function