Palabras clave: formulario, menú, API
Autor: Candace Tripp
Extraído de: Utter Access (allá por 2007)
Objetivo:
Crear un menú flotante en el formulario.
Utilizamos un formulario con 3 botones (el ejemplo original utiliza 3 botones transparentes encima de 3 etiquetas pero se puede hacer con botones de fondo transparente)
En el módulo de clase del ejemplo las opciones se definen "a pedal". Se podría trabajar con una tabla que llame a funciones (a estudiar)
El código del formulario es este:
Option Compare Database
Option Explicit
Dim oMenu As cMenu
Private Sub mnuFile_Click()
oMenu.ShowMenu "File"
End Sub
Private Sub mnuEdit_Click()
oMenu.ShowMenu "Edit"
End Sub
Private Sub mnuHelp_Click()
oMenu.ShowMenu "About"
End Sub
Private Sub Form_Load()
Set oMenu = New cMenu
Set oMenu.CurrentForm = Me
End Sub
Después tenemos un módulo de clase como este:
Option Compare Database
Option Explicit
'######################################################################
'
'CLASSNAME : cMenu
'
'PURPOSE : Class to emulate a drop down menu using API calls
'
'DATE CREATED : 2/2/2005
'
'AUTHOR : Candace Tripp
' http://www.candace-tripp.com/
'
'NOTE : This API calls/code is a modification of Bryan Stafford's
' popup menu demo project written in Visual Basic 6.
' This demo is released into the public domain "as is" without
' warranty or guaranty of any kind. In other words, use at your own risk.
' His comments are below
'
'MODIFICATIONS:
' DATE MODIFIED BY MODIFICATION DESCRIPTION
' ---- ----------- -----------------------------------------
'
'######################################################################
'Bryan Stafford of New Vision Software
'######################################################################
' demo project showing how to use the API menu functions to create a
' popup menu. by Bryan Stafford of New Vision Software - newvision@mvps.org
' this demo is released into the public domain "as is" without warranty or
' guaranty of any kind. In other words, use at your own risk.
' the handles to our popup menus. we keep them at the module level so that
' we don't have to recreate the menus each time we want to display them.
'######################################################################
Private m_CurrentForm As Form
Private m_lngItemWidth As Long
Private m_lngItemTop As Long
Private m_hMenu(3) As Long
Private m_hSubMenu(3) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Const MF_INSERT As Long = &H0&
Private Const MF_CHANGE As Long = &H80&
Private Const MF_APPEND As Long = &H100&
Private Const MF_DELETE As Long = &H200&
Private Const MF_REMOVE As Long = &H1000&
Private Const MF_BYCOMMAND As Long = &H0&
Private Const MF_BYPOSITION As Long = &H400&
Private Const MF_SEPARATOR As Long = &H800&
Private Const MF_ENABLED As Long = &H0&
Private Const MF_GRAYED As Long = &H1&
Private Const MF_DISABLED As Long = &H2&
Private Const MF_UNCHECKED As Long = &H0&
Private Const MF_CHECKED As Long = &H8&
Private Const MF_USECHECKBITMAPS As Long = &H200&
Private Const MF_STRING As Long = &H0&
Private Const MF_BITMAP As Long = &H4&
Private Const MF_OWNERDRAW As Long = &H100&
Private Const MF_POPUP As Long = &H10&
Private Const MF_MENUBARBREAK As Long = &H20&
Private Const MF_MENUBREAK As Long = &H40&
Private Const MF_UNHILITE As Long = &H0&
Private Const MF_HILITE As Long = &H80&
Private Const MF_SYSMENU As Long = &H2000&
Private Const MF_HELP As Long = &H4000&
Private Const MF_MOUSESELECT As Long = &H8000&
Private Const TPM_RETURNCMD As Long = &H100&
Private Const ID_BEEP As Long = &H6000&
Private Const ID_SEPARATOR As Long = &H6001&
Private Const ID_DISABLED As Long = &H6002&
Private Const ID_MSGBOX As Long = &H6003&
Private Const ID_ADD As Long = &H6004&
Private Const ID_EDIT As Long = &H6005&
Private Const ID_DELETE As Long = &H6006&
Private Const ID_EXIT As Long = &H6007&
Private Const ID_HELP As Long = &H6008&
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 ClientToScreen& Lib "user32" (ByVal hwnd&, lpPoint As POINTAPI)
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu&, ByVal wFlags&, ByVal X&, ByVal Y&, ByVal nReserved&, ByVal hwnd&, ByVal lpRect&) As Long
Private Declare Function EnableMenuItem Lib "user32" (ByVal hMenu&, ByVal wIDEnableItem&, ByVal wEnable&) As Long
'PROPERTIES ###########################################################
Public Property Set CurrentForm(frmCurrent As Form)
Set m_CurrentForm = frmCurrent
End Property
Public Property Get CurrentForm() As Form
On Error Resume Next
If IsObject(m_CurrentForm) Then
Set CurrentForm = m_CurrentForm
End If
End Property
Public Property Let ItemTop(lngValue As Long)
m_lngItemTop = lngValue
End Property
Public Property Get ItemTop() As Long
ItemTop = m_lngItemTop
End Property
Public Property Let ItemWidth(lngValue As Long)
m_lngItemWidth = lngValue
End Property
Public Property Get ItemWidth() As Long
ItemWidth = m_lngItemWidth
End Property
'END PROPERTIES #######################################################
'METHODS ##############################################################
Public Sub ShowMenu(strMenuName As String)
Dim intItem As Integer
Select Case strMenuName
Case "File"
intItem = 0
Case "Edit"
intItem = 1
Case Else '"About"
intItem = 2
End Select
DisplayPopupMenu intItem, ItemWidth * intItem, ItemTop
End Sub
'END METHODS ##########################################################
'######################################################################
Private Sub Class_Initialize()
' defaults
m_lngItemWidth = 64
m_lngItemTop = 19
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Dim intItem1 As Integer
Dim intItem2 As Integer
For intItem1 = 0 To UBound(m_hMenu) - 1
If m_hMenu(intItem1) Then
Call DestroyMenu(m_hMenu(intItem1))
End If
Next intItem1
For intItem2 = 0 To UBound(m_hSubMenu) - 1
If m_hSubMenu(intItem2) Then
Call DestroyMenu(m_hSubMenu(intItem2))
End If
Next intItem2
End Sub
'######################################################################
'######################################################################
Private Sub DisplayPopupMenu(intItem As Integer, ByVal X&, ByVal Y&)
Dim pt As POINTAPI
Dim lngReturn As Long
' if the menu hasn't already been created, create it....
If m_hMenu(intItem) = 0 Then
Select Case intItem
Case 0 ' File
m_hMenu(intItem) = CreatePopupMenu()
' add an item....
Call AppendMenu(m_hMenu(intItem), MF_STRING, ID_BEEP, ByVal "Sound A ""Beep""")
' add a separator....
Call AppendMenu(m_hMenu(intItem), MF_STRING Or MF_SEPARATOR, ID_SEPARATOR, ByVal vbNullString)
' add another item....
Call AppendMenu(m_hMenu(intItem), MF_STRING, ID_DISABLED, ByVal "A Disabled Item")
' disable the last item we added....
Call EnableMenuItem(m_hMenu(intItem), ID_DISABLED, MF_BYCOMMAND Or MF_DISABLED Or MF_GRAYED)
' add the next item....
Call AppendMenu(m_hMenu(intItem), MF_STRING, ID_MSGBOX, ByVal "Display A MessageBox")
' add a separator....
Call AppendMenu(m_hMenu(intItem), MF_STRING Or MF_SEPARATOR, ID_SEPARATOR, ByVal vbNullString)
' add the last item....
Call AppendMenu(m_hMenu(intItem), MF_STRING, ID_EXIT, ByVal "Exit")
Case 1 ' Edit
' first create our sub menu....
m_hSubMenu(intItem) = CreatePopupMenu()
' add a couple of items to the sub menu....
Call AppendMenu(m_hSubMenu(intItem), MF_STRING, ID_ADD, ByVal "Add")
Call AppendMenu(m_hSubMenu(intItem), MF_STRING, ID_EDIT, ByVal "Edit")
Call AppendMenu(m_hSubMenu(intItem), MF_STRING, ID_DELETE, ByVal "Delete")
m_hMenu(intItem) = CreatePopupMenu()
' add the item to which we attach the sub menu....
Call AppendMenu(m_hMenu(intItem), MF_STRING Or MF_POPUP, m_hSubMenu(intItem), ByVal "Edit")
Case Else ' About
m_hMenu(intItem) = CreatePopupMenu()
' add an item....
Call AppendMenu(m_hMenu(intItem), MF_STRING, ID_HELP, ByVal "Help")
' add a separator....
Call AppendMenu(m_hMenu(intItem), MF_STRING Or MF_SEPARATOR, ID_SEPARATOR, ByVal vbNullString)
' add the last item....
Call AppendMenu(m_hMenu(intItem), MF_STRING, ID_MSGBOX, ByVal "About")
End Select
End If
With pt ' the x & y position where you want the menu displayed
.X = X
.Y = Y
' translate to screen coordinates
Call ClientToScreen(CurrentForm.hwnd, pt)
' call the api function to display the menu and check the return value
lngReturn = TrackPopupMenu(m_hMenu(intItem), TPM_RETURNCMD, .X, .Y, 0&, CurrentForm.hwnd, 0&)
Call MenuAction(lngReturn)
End With
End Sub
Private Sub MenuAction(lngReturn As Long)
On Error Resume Next
Select Case lngReturn
Case ID_BEEP
Beep
Case ID_MSGBOX
MsgBox "Form with Menu created by Candace Tripp" & vbCrLf & "http://www.candace-tripp.com/", vbInformation
Case ID_ADD
MsgBox "You chose ""Add"".", vbExclamation
Case ID_EDIT
MsgBox "You chose ""Edit"".", vbExclamation
Case ID_DELETE
MsgBox "You chose ""Delete"".", vbExclamation
Case ID_HELP
SendKeys "{F1}"
Case ID_EXIT
DoCmd.Close acForm, CurrentForm.Name, acSavePrompt
End Select
End Sub
'######################################################################
