Option Compare Database
Option Explicit
'***************************************************************
'& &*
'& &*
'& &*
'& &*
'& Jefferson Jimenez (JJJT) &*
'& Cabimas - Venezuela &*
'& Mayo - 2010 &*
'& &*
'& &*
'& &*
'& &*
'& &*
'***************************************************************
'& http://sites.google.com/site/jjjt1973/ejemplos-access &*
'& Crear un Menu PopUp recurriendo al API de Windows &*
'& Referencia Alessandro Baraldi &*
'***************************************************************
'Constantes del Menu
Const MF_CHECKED = &H8&
Const MF_APPEND = &H100&
Const TPM_LEFTALIGN = &H0&
Const MF_DISABLED = &H2&
Const MF_GRAYED = &H1&
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Const TPM_RETURNCMD = &H100&
Const TPM_RIGHTBUTTON = &H2&
Private Type POINTAPI
X As Long
Y As Long
End Type
'Declaraciones al API de WINDOWS
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal HWnd As Long, ByVal lptpm As Any) 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 DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'Variables de Uso
Dim hMenu As Long
Dim Sel As Boolean
Sub MenuPopUp(frm As Form)
Dim Pt As POINTAPI
Dim ret As Long
hMenu = CreatePopupMenu()
AppendMenu hMenu, TPM_LEFTALIGN, 1, "Hola ..!"
AppendMenu hMenu, MF_GRAYED, 2, "Protegido"
AppendMenu hMenu, MF_SEPARATOR, 3, ByVal 0&
If Sel = False Then
AppendMenu hMenu, MF_CHECKED, 4, "Desactivar"
Else
AppendMenu hMenu, MF_STRING, 4, "Activar"
End If
AppendMenu hMenu, MF_STRING, 5, "Salir...?"
GetCursorPos Pt
ret = TrackPopupMenuEx(hMenu, TPM_LEFTALIGN Or _
TPM_RETURNCMD Or _
TPM_RIGHTBUTTON, _
Pt.X, Pt.Y, frm.HWnd, ByVal 0&)
Select Case ret
Case 1
MsgBox "Hola Programador", vbExclamation, "Menu PopUp"
Case 4
If Sel Then
Sel = False
Else
Sel = True
End If
Case 5
MsgBox "Salimos de Access" & vbCr & "Adios....!", vbExclamation, "Menu PopUp"
DoCmd.Quit
End Select
DestroyMenu hMenu
End Sub