API MenuPopUp (Facil)

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