DominoArea.org [Archive]

[syntax="ls"]Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Type POINTAPI
x As Long
y As Long
End Type

Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type

Declare Function GetCursorPos Lib "user32" Alias "GetCursorPos" (lpPoint As POINTAPI) As Long
Declare Function CreatePopupMenu Lib "user32" Alias "CreatePopupMenu" () As Long
Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (Byval hMenu As Long, Byval wFlags As Long, Byval wIDNewItem As Integer, Byval lpNewItem As Any) As Long
Declare Function TrackPopupMenu Lib "user32" Alias "TrackPopupMenu" (Byval hMenu As Long, Byval wFlags As Long, Byval x As Long, Byval y As Long, Byval nReserved As Long, Byval hwnd As Long, lprc As Rect) As Long
Declare Function DestroyMenu Lib "user32" Alias "DestroyMenu" (Byval hMenu As Long) As Long
Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, Byval hwnd As Long, Byval wMsgFilterMin As Long, Byval wMsgFilterMax As Long) As Long
Declare Function GetActiveWindow Lib "user32" Alias "GetActiveWindow" () As Long

Function PopMenu (pstrItem As String, mx As Long, my As Long) As Long

Const MF_ENABLED = &H0
Const TPM_LEFTALIGN = &H0
Const MF_SEPARATOR = &H800
Const SEP = ";"
Dim msgdata As MSG
Dim rectdata As RECT
Dim Cursor As POINTAPI
Redim strItem(1 To 20) As String
Dim i As Long
Dim j As Long
Dim last As Long
Dim hMenu As Long
Dim id As Integer
Dim junk As Long


If Right$(pstrItem, 1) <> SEP Then pstrItem = pstrItem + SEP
j = 1
Do
i = Instr(j, pstrItem, SEP)
If i Then
last = last + 1
strItem(last) = Mid$(pstrItem, j, i - j)
j = i + 1
End If
Loop Until i = 0

hMenu = CreatePopupMenu()

id = 1
For i = 1 To last
If strItem(i) <> "-" Then
junk = AppendMenu(hMenu, MF_ENABLED, id, strItem(i))
id = id + 1
Else
junk = AppendMenu(hMenu, MF_SEPARATOR, 0, "")
End If
Next

If mx = 0 And my = 0 Then
Call GetCursorPos(Cursor)
mx = Cursor.x
my = Cursor.y
End If

junk = TrackPopupMenu(hMenu, TPM_LEFTALIGN, mx, my, 0, GetActiveWindow(), rectdata)
junk = GetMessage(msgdata, GetActiveWindow(), 0, 0)

i = Abs(msgdata.wparam)
If msgdata.message = 273 Then
PopMenu = i
End If
Call DestroyMenu(hMenu)
End Function[/syntax]
[syntax="ls"]Sub Click(Source As Button)
Dim sess As New NotesSession
Dim ws As New NotesUIWorkspace

Select Case PopMenu("Memo;Répondre;Répondre avec historique",0,0)
Case 1
Call ws.ComposeDocument(sess.CurrentDatabase.Server, sess.CurrentDatabase.FilePath , "Memo",)
Case 2
Call ws.ComposeDocument(sess.CurrentDatabase.Server, sess.CurrentDatabase.FilePath , "Répondre",)
Case 3
Call ws.ComposeDocument(sess.CurrentDatabase.Server, sess.CurrentDatabase.FilePath , "Répondre avec historique")
End Select
End Sub[/syntax]Utilisation :
PopMenu( TexteMenu , position X , position Y) as Long

Elements :
TexteMenu
Chaîne de caractère. Séparateur de menu ";". Ligne de séparation "-". Raccourci "&".

ex. "&Memo;&Répondre;Répondre avec historique;-;Fermer la base"
position X
Coordonnées X
y position
Coordonnées Y.
Valeur retournée
Le long correspond à la sélection de l'utilisateur. Si aucun élément sélectionner la fonction retourne 0.

ma version

Code : Tout sélectionner

Public Function PopMenu_API(wLstMenu,nbPositionX As Long, nbPositionY As Long) As Long
   %REM
      Type FOUR_LONG
      nbLong1 As Long 'Left
      nbLong2 As Long 'Top
      nbLong3 As Long 'Right
      nbLong4 As Long 'Bottom
      End Type
      Type TWO_LONG
      nbLong1 As Long 'x
      nbLong2 As Long 'y
      End Type
      Type MSG
      hwnd As Long
      message As Long
      wParam As Long
      lParam As Long
      time As Long
      pt As TWO_LONG
      End Type

      Declare Function GetActiveWindow Lib "user32" Alias "GetActiveWindow" () As Long
      Declare Function GetCursorPos Lib "user32" Alias "GetCursorPos" (lpPoint As TWO_LONG) As Long
      Declare Function CreatePopupMenu Lib "user32" Alias "CreatePopupMenu" () As Long
      Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (Byval wnbHandleMenu As Long, Byval wnbFlags As Long, Byval wIDNewItem As Integer, Byval lpNewItem As Any) As Long
      Declare Function TrackPopupMenu Lib "user32" Alias "TrackPopupMenu" (Byval wnbHandleMenu As Long, Byval wFlags As Long, Byval wnbPositionX As Long, Byval wnbPositionY As Long, Byval wnbReserved As Long, Byval hwnd As Long, lprc As FOUR_LONG) As Long
      Declare Function DestroyMenu Lib "user32" Alias "DestroyMenu" (Byval wnbHandleMenu As Long) As Long
      Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, Byval wnbHandelWindow As Long, Byval wnbMsgFilterMin As Long, Byval wnbMsgFilterMax As Long) As Long
   %END REM
   Dim nbHandleMenu As Long
   Dim nbResult As Long
   Dim i As Integer
   Const MF_ENABLED = &H0
   Const MF_GRAYED = &H1
   Const MF_CHEKED = &H8
   Const MF_DISABLED = &H2
   Const TPM_LEFTALIGN = &H0
   Const MF_SEPARATOR = &H800
   Dim Cursor As TWO_LONG
   Dim msgdata As MSG
   Dim rectdata As FOUR_LONG
   Dim Separator As String
   
   On Error Goto CatchError
   
   nbHandleMenu = CreatePopupMenu()
   i=0
   Separator = ";"
   
   Forall value In wlstMenu
      Select Case Ucase(Trim(Cstr(value)))
      Case "","-","MF_SEPARATOR","SEPARATOR","&H800"
         nbResult = AppendMenu(nbHandleMenu, MF_SEPARATOR, 0, "")
      Case Else
         i=i+1
         If Trim(Strright(Cstr(value),Separator)) = "" Then
            nbResult = AppendMenu(nbHandleMenu, MF_ENABLED,i, Cstr(value))
         Else           
            Select Case Ucase(Trim(Strleft(Cstr(value),Separator)))
            Case "E","ENABLED","MF_ENABLED","&H0","H0","0"
               nbResult = AppendMenu(nbHandleMenu, MF_ENABLED,i, Strright(Cstr(value),Separator))
            Case "G","GRAYED","MF_GRAYED","&H1","H1","1"
               nbResult = AppendMenu(nbHandleMenu, MF_GRAYED,i, Strright(Cstr(value),Separator))
            Case "C","CHEKED","MF_CHEKED","&H8","H8","8"
               nbResult = AppendMenu(nbHandleMenu, MF_CHEKED,i, Strright(Cstr(value),Separator))
            Case "D","DISABLED","MF_DISABLED","&H2","H2","2"
               nbResult = AppendMenu(nbHandleMenu, MF_DISABLED,i, Strright(Cstr(value),Separator))
            Case Else
               nbResult = AppendMenu(nbHandleMenu, MF_ENABLED,i, Strright(Cstr(value),Separator))
            End Select
         End If
      End Select
   End Forall
   
   If i=0 Then
      Error 9999,"pas de menu a afficher"
      Exit Function
   End If
   
   If nbPositionX = 0 Or  nbPositionY = 0 Then
      Call GetCursorPos(Cursor)
      If nbPositionX = 0 Then
         nbPositionX = Cursor.nbLong1
      End If
      If nbPositionY = 0 Then
         nbPositionY = Cursor.nbLong2
      End If
   End If
   
   nbResult  = TrackPopupMenu(nbHandleMenu, TPM_LEFTALIGN, nbPositionX, nbPositiony, 0, GetActiveWindow(), rectdata)
   nbResult  = GetMessage(msgdata, GetActiveWindow(), 0, 0)
   
   If msgdata.message = 273 Then
      PopMenu_API = Abs(msgdata.wparam)
   End If
   
   Call DestroyMenu(nbHandleMenu)
   
   %REM

      exemple d'appel

      Dim lstvalue List As String
      lstvalue(0) = "E;Menu1 :"
      lstvalue(1) = "-"
      lstvalue(2) = "G;Menu 2 :"
      lstvalue(3) = "C;Menu 3 :"
      lstvalue(4) = "-"
      lstvalue(5) = "D;Menu 4 :"
      Dim i As Long
      i=  PopMenu_API(lstvalue,0,0)
   %END REM
   Exit Function
CatchError:
   Msgbox "("+Structure_Log+" : "+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + CStr(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   On Error Resume Next
   If nbHandleMenu>0 Then
      Call DestroyMenu(nbHandleMenu)
   End If
   PopMenu_API = -1
   Exit Function
End Function