[转贴]：MENUS

eachy

2. 
   
3. Option Explicit
   
4. 
   
5. '          THE API STRIKES AGAIN
   
6. '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
   
7. '   A Painful introduction into using the
   
8. '   The WIN32API to fill in the gaps between
   
9. '   VBA and Visual Basic.
   
10. 
    
11. '   These are TYPES - Like an Array, but each
    
12. '   Element can be a different data type.
    
13. 
    
14. Private Type MENUITEMINFO
    
15.     cbSize As Long
    
16.     fMask As Long
    
17.     fType As Long
    
18.     fState As Long
    
19.     wID As Long
    
20.     hSubMenu As Long
    
21.     hbmpChecked As Long
    
22.     hbmpUnchecked As Long
    
23.     dwItemData As Long
    
24.     dwTypeData As String
    
25.     cch As Long
    
26. End Type
    
27. 
    
28. Private Type POINTAPI
    
29.   x As Long
    
30.   y As Long
    
31. End Type
    
32. 
    
33. '   These are Functions in Windows Dynamic Link
    
34. '   Libraries. By using the syntax you see here,
    
35. '   We use these functions in our VBA projects
    
36. '   Perhaps the most important thing to remember
    
37. '   When you start experimenting with this code:
    
38. '   SAVE - SAVE - SAVE
    
39. 
    
40. Private Declare Function GetCursorPos Lib "user32" _
    
41. (lpPoint As POINTAPI) As Long
    
42. 
    
43. Private Declare Function CreatePopupMenu Lib _
    
44. "user32" () As Long
    
45. 
    
46. Private Declare Function TrackPopupMenuEx Lib "user32" _
    
47. (ByVal hMenu As Long, ByVal un As Long, _
    
48. ByVal n1 As Long, ByVal n2 As Long, _
    
49. ByVal hwnd As Long, lpTPMParams As Any) As Long
    
50. 
    
51. Private Declare Function InsertMenuItem Lib "user32" _
    
52. Alias "InsertMenuItemA" (ByVal hMenu As Long, _
    
53. ByVal un As Long, ByVal bool As Long, _
    
54. lpcMenuItemInfo As MENUITEMINFO) As Long
    
55. 
    
56. Private Declare Function DestroyMenu Lib "user32" _
    
57. (ByVal hMenu As Long) As Long
    
58. 
    
59. Private Declare Function FindWindow Lib "user32" _
    
60. Alias "FindWindowA" (ByVal lpClassName As String, _
    
61. ByVal lpWindowName As String) As Long
    
62. 
    
63. '   These are constants (Fixed values) used in
    
64. '   Calls to the functions listed above.
    
65. Private Const MF_STRING = &H0&
    
66. Private Const TPM_RETURNCMD = &H100&
    
67. Private Const MIIM_ID = &H2
    
68. Private Const MIIM_TYPE = &H10
    
69. Private Const MIIM_DATA = &H20
    
70. 
    
71. '   These are variables used in the
    
72. '   Events and procedures..
    
73. Dim lngMnu As Long
    
74. Dim lngHwnd As Long
    
75. Dim lngID As Long
    
76. Dim PT As POINTAPI
    
77. Dim objMNU As MENUITEMINFO
    
78. 
    
79. 'And the Events Begin!
    
80. 
    
81. Private Sub UserForm_Initialize()
    
82.   Dim strArray(1 To 3) As String
    
83.   Dim lngCnt As Long
    
84.   strArray(1) = "Cut"
    
85.   strArray(2) = "Copy"
    
86.   strArray(3) = "Paste"
    
87.   lngMnu = CreatePopupMenu()
    
88.   lngHwnd = FindWindow(vbNullString, Me.Caption)
    
89.   For lngCnt = 1 To 3
    
90.   With objMNU
    
91.     .cbSize = Len(objMNU)
    
92.     .fMask = MIIM_TYPE Or MIIM_ID Or MIIM_DATA
    
93.     .dwTypeData = strArray(lngCnt)
    
94.     .cch = Len(strArray(lngCnt))
    
95.     .fType = MF_STRING
    
96.     .wID = lngCnt
    
97.   End With
    
98.   Call InsertMenuItem(lngMnu, lngCnt, 1, objMNU)
    
99.   Next lngCnt
    
100. End Sub
     
101. 
     
102. Private Sub TextBox1_MouseUp(ByVal Button As Integer, _
     
103. ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
     
104.   If Button = 2 Then
     
105.     GetCursorPos PT
     
106.     lngID = TrackPopupMenuEx(lngMnu, TPM_RETURNCMD, PT.x, _
     
107.     PT.y, lngHwnd, ByVal 0&)
     
108.     Select Case lngID
     
109.     Case 1
     
110.       TextBox1.Cut
     
111.     Case 2
     
112.       TextBox1.Copy
     
113.     Case 3
     
114.       TextBox1.Paste
     
115.     End Select
     
116.   End If
     
117. End Sub
     
118. 
     
119. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     
120.   Call DestroyMenu(lngMnu)
     
121. End Sub

<br /> Option Explicit<br /> <br /> '          THE API STRIKES AGAIN<br /> '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@<br /> '   A Painful introduction into using the<br /> '   The WIN32API to fill in the gaps between<br /> '   VBA and Visual Basic.<br /> <br /> '   These are TYPES - Like an Array, but each<br /> '   Element can be a different data type.<br /> <br /> Private Type MENUITEMINFO<br />     cbSize As Long<br />     fMask As Long<br />     fType As Long<br />     fState As Long<br />     wID As Long<br />     hSubMenu As Long<br />     hbmpChecked As Long<br />     hbmpUnchecked As Long<br />     dwItemData As Long<br />     dwTypeData As String<br />     cch As Long<br /> End Type<br /> <br /> Private Type POINTAPI<br />   x As Long<br />   y As Long<br /> End Type<br /> <br /> '   These are Functions in Windows Dynamic Link<br /> '   Libraries. By using the syntax you see here,<br /> '   We use these functions in our VBA projects<br /> '   Perhaps the most important thing to remember<br /> '   When you start experimenting with this code:<br /> '   SAVE - SAVE - SAVE<br /> <br /> Private Declare Function GetCursorPos Lib "user32" _<br /> (lpPoint As POINTAPI) As Long<br /> <br /> Private Declare Function CreatePopupMenu Lib _<br /> "user32" () As Long<br /> <br /> Private Declare Function TrackPopupMenuEx Lib "user32" _<br /> (ByVal hMenu As Long, ByVal un As Long, _<br /> ByVal n1 As Long, ByVal n2 As Long, _<br /> ByVal hwnd As Long, lpTPMParams As Any) As Long<br /> <br /> Private Declare Function InsertMenuItem Lib "user32" _<br /> Alias "InsertMenuItemA" (ByVal hMenu As Long, _<br /> ByVal un As Long, ByVal bool As Long, _<br /> lpcMenuItemInfo As MENUITEMINFO) As Long<br /> <br /> Private Declare Function DestroyMenu Lib "user32" _<br /> (ByVal hMenu As Long) As Long<br /> <br /> Private Declare Function FindWindow Lib "user32" _<br /> Alias "FindWindowA" (ByVal lpClassName As String, _<br /> ByVal lpWindowName As String) As Long<br /> <br /> '   These are constants (Fixed values) used in<br /> '   Calls to the functions listed above.<br /> Private Const MF_STRING = &H0&<br /> Private Const TPM_RETURNCMD = &H100&<br /> Private Const MIIM_ID = &H2<br /> Private Const MIIM_TYPE = &H10<br /> Private Const MIIM_DATA = &H20<br /> <br /> '   These are variables used in the<br /> '   Events and procedures..<br /> Dim lngMnu As Long<br /> Dim lngHwnd As Long<br /> Dim lngID As Long<br /> Dim PT As POINTAPI<br /> Dim objMNU As MENUITEMINFO<br /> <br /> 'And the Events Begin!<br /> <br /> Private Sub UserForm_Initialize()<br />   Dim strArray(1 To 3) As String<br />   Dim lngCnt As Long<br />   strArray(1) = "Cut"<br />   strArray(2) = "Copy"<br />   strArray(3) = "Paste"<br />   lngMnu = CreatePopupMenu()<br />   lngHwnd = FindWindow(vbNullString, Me.Caption)<br />   For lngCnt = 1 To 3<br />   With objMNU<br />     .cbSize = Len(objMNU)<br />     .fMask = MIIM_TYPE Or MIIM_ID Or MIIM_DATA<br />     .dwTypeData = strArray(lngCnt)<br />     .cch = Len(strArray(lngCnt))<br />     .fType = MF_STRING<br />     .wID = lngCnt<br />   End With<br />   Call InsertMenuItem(lngMnu, lngCnt, 1, objMNU)<br />   Next lngCnt<br /> End Sub<br /> <br /> Private Sub TextBox1_MouseUp(ByVal Button As Integer, _<br /> ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)<br />   If Button = 2 Then<br />     GetCursorPos PT<br />     lngID = TrackPopupMenuEx(lngMnu, TPM_RETURNCMD, PT.x, _<br />     PT.y, lngHwnd, ByVal 0&)<br />     Select Case lngID<br />     Case 1<br />       TextBox1.Cut<br />     Case 2<br />       TextBox1.Copy<br />     Case 3<br />       TextBox1.Paste<br />     End Select<br />   End If<br /> End Sub<br /> <br /> Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)<br />   Call DestroyMenu(lngMnu)<br /> End Sub