Aporte: Crear PopupMenu por API Facilísimo

[erbuson]

Esta es una mejora al PopUpMenu que considero muy importante, por tanto aqui os dejo todo el código y el ejemplo.

Código para pegar en un Modulo

Código vb:

Option Explicit
  
Private Type POINTAPI
  X As Long
  Y As Long
End Type
    
Private Declare Function CreatePopupMenu Lib "User32" () As Long
Private Declare Function DestroyMenu Lib "User32" (ByVal hMenu&) As Long
Private Declare Function AppendMenu Lib "User32" Alias "AppendMenuA" (ByVal hMenu&, ByVal wFlags&, ByVal wIDNewItem&, ByVal lpNewItem$) As Long
Private Declare Function TrackPopupMenu Lib "User32" (ByVal hMenu&, ByVal wFlags&, ByVal X&, ByVal Y&, ByVal nReserved&, ByVal Hwnd&, ByVal lpRect&) As Long
Private Declare Sub GetCursorPos Lib "User32" (lpPoint As POINTAPI)
 
 
Public Function ElegirMenu(Hwnd As Long, MiMenu As String, Optional Numero As Boolean = False) As String
  Dim HwMenus(25) As Long, HwMenu As Integer
  Dim Menus() As String, SubMenus() As String, Elemento As Integer, Linea As Integer
  Dim Valor As Long
  Dim Titulos(1000) As String
  HwMenus(0) = CreatePopupMenu()
  Menus() = Split(MiMenu, "/")
  For Elemento = 0 To UBound(Menus)
    Valor = Valor + 1
    If InStr(Menus(Elemento), ";") Then
      ' Es un SubMenu
      SubMenus() = Split(Menus(Elemento), ";")
      HwMenu = HwMenu + 1
      HwMenus(HwMenu) = CreatePopupMenu()
      For Linea = 1 To UBound(SubMenus)
        Call CrearItemMenu(HwMenus(HwMenu), SubMenus(Linea), CLng(100 * HwMenu + Linea))
        Titulos(100 * HwMenu + Linea) = SubMenus(0) & SubMenus(Linea)
      Next
      If Left$(SubMenus(0), 1) = "#" Then
        Call AppendMenu(HwMenus(0), &H0& Or &H10& Or &H1&, HwMenus(HwMenu), ByVal Mid$(SubMenus(0), 2))
      Else
        Call AppendMenu(HwMenus(0), &H0& Or &H10&, HwMenus(HwMenu), ByVal SubMenus(0))
      End If
    ElseIf Menus(Elemento) = "-" Then
      Call CrearItemMenu(HwMenus(0), Menus(Elemento), 999)
    Else
      Call CrearItemMenu(HwMenus(0), Menus(Elemento), Valor)
      Titulos(Valor) = Menus(Elemento)
    End If
  Next
  Dim Donde As POINTAPI
  GetCursorPos Donde
  Valor = TrackPopupMenu(HwMenus(0), &H100&, Donde.X, Donde.Y, 0&, Hwnd, 0&)
  If Numero Then
    ElegirMenu = Trim$(Str$(Valor))
  Else
    ElegirMenu = Titulos(Valor)
  End If
  For Linea = 0 To HwMenu
    DestroyMenu HwMenus(Linea)
  Next
End Function
 
Private Sub CrearItemMenu(HWndMenu As Long, Texto As String, Valor As Long)
  ' Crea en el Menu indicado el Item. Controlando diversas opciones del mismo.
  If Texto = "-" Then
    Call AppendMenu(HWndMenu, &H0& Or &H800&, 999&, ByVal vbNullString)
  Else
    If Left$(Texto, 1) = "'" Then
      Texto = Mid$(Texto, 2)
      Call AppendMenu(HWndMenu, &H0& Or &H8&, Valor, ByVal Texto)
    ElseIf Left$(Texto, 1) = "#" Then
      Texto = Mid$(Texto, 2)
      Call AppendMenu(HWndMenu, &H0& Or &H1&, Valor, ByVal Texto)
    Else
      Call AppendMenu(HWndMenu, &H0&, Valor, ByVal Texto)
    End If
  End If
End Sub
 

Para probar su funcionamiento, simplemente basta con pegar este código en un Formulario.

Código vb:

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbRightButton Then
  MsgBox ElegirMenu(Me.Hwnd, "Leer/-/#Editar;Copiar;'Pegar;Cortar/Grabar/Color;Verde;Rojo;#Azul/'Salir")
End If
End Sub
 

Como veis su uso no puede ser mas simple:

Las barras / separan los Elementos del Menu, un elemento puede estar Bloqueado si indicamos # delante del mismo o Seleccionado si indicamos apostrofe ' delante de éste Además un elemento de menú puede ser un SubMenu si contiene elementos separados por punto y coma ;

En el ejemplo estan todas las posibilidades:
"Leer/-/#Editar;Copiar;'Pegar;Cortar/Grabar/Color;Verde;Rojo;#Azul/'Salir"

No obstante cualquier duda comentad.

Saludos