Autor Tema: Crear menú flotante  (Leído 2736 veces)

Desconectado xavi

  • Administrador
  • Habitual
  • *****
  • Mensajes: 213
Crear menú flotante
« en: Mayo 02, 2020, 05:08:16 pm »
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:

Código: [Seleccionar]
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:

Código: [Seleccionar]
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
'######################################################################