home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Cre8Popup2068365312007.psc / Cre8Popup.Frm < prev    next >
Text File  |  2007-05-31  |  22KB  |  363 lines
  1. VERSION 5.00
  2. Begin VB.Form Cre8Popup 
  3.    BackColor       =   &H80000007&
  4.    Caption         =   "Click inside the form..."
  5.    ClientHeight    =   5490
  6.    ClientLeft      =   60
  7.    ClientTop       =   450
  8.    ClientWidth     =   7875
  9.    LinkTopic       =   "Form1"
  10.    ScaleHeight     =   366
  11.    ScaleMode       =   3  'Pixel
  12.    ScaleWidth      =   525
  13.    StartUpPosition =   3  'Windows Default
  14. End
  15. Attribute VB_Name = "Cre8Popup"
  16. Attribute VB_GlobalNameSpace = False
  17. Attribute VB_Creatable = False
  18. Attribute VB_PredeclaredId = True
  19. Attribute VB_Exposed = False
  20. '
  21. '*************************************************************************
  22. '*************************************************************************
  23. '****                                                                 ****
  24. '****    This is the PopUp Menu Tutorial.                             ****
  25. '****                                                                 ****
  26. '****    Written by:  Randy Giese                                     ****
  27. '****    Company:     RandyGrams                                      ****
  28. '****    Date:        April 09, 2007                                  ****
  29. '****                                                                 ****
  30. '****    I struggled with PopUp Menus because I was not able to       ****
  31. '****    find very good documentation.  I found examples on PSC       ****
  32. '****    and elsewhere but they seemed too limited, as well as        ****
  33. '****    complex and difficult, to relate to my own coding.  So I     ****
  34. '****    decided to dig into it and was able to come up with this     ****
  35. '****    brief Tutorial.  I hope you find it helpful...               ****
  36. '****                                                                 ****
  37. '****    Randy Giese                                                  ****
  38. '****                                                                 ****
  39. '*************************************************************************
  40. '*************************************************************************
  41. '
  42. Option Explicit
  43. Private lngBoxNum                    As Long
  44. '
  45. '*************************************************************************
  46. '****                                                                 ****
  47. '****    These are the Constants for the 'AppendMenu' Function.       ****
  48. '****                                                                 ****
  49. '****    Note:                                                        ****
  50. '****    I included all of the Menu Function Constants and the        ****
  51. '****    TrackPopupMenu Constants for completeness.                   ****
  52. '****                                                                 ****
  53. '*************************************************************************
  54. '
  55. Private Const MF_APPEND             As Long = &H100&
  56. Private Const MF_CHECKED            As Long = &H8&
  57. Private Const MF_DISABLED           As Long = &H2&
  58. Private Const MF_GRAYED             As Long = &H1&
  59. Private Const MF_POPUP              As Long = &H10&
  60. Private Const MF_SEPARATOR          As Long = &H800&
  61. Private Const MF_STRING             As Long = &H0&
  62. Private Const MF_UNCHECKED          As Long = &H0&
  63. '
  64. '*************************************************************************
  65. '****                                                                 ****
  66. '****    These are the Constants for the 'TrackPopupMenuEx'           ****
  67. '****    Function.                                                    ****
  68. '****                                                                 ****
  69. '*************************************************************************
  70. '
  71. Private Const TPM_BOTTOMALIGN       As Long = &H20&
  72. Private Const TPM_CENTERALIGN       As Long = &H4&
  73. Private Const TPM_HORIZONTAL        As Long = &H0&
  74. Private Const TPM_HORNEGANIMATION   As Long = &H800&
  75. Private Const TPM_HORPOSANIMATION   As Long = &H400&
  76. Private Const TPM_LEFTALIGN         As Long = &H0&
  77. Private Const TPM_LEFTBUTTON        As Long = &H0&
  78. Private Const TPM_NOANIMATION       As Long = &H4000&
  79. Private Const TPM_NONOTIFY          As Long = &H80&
  80. Private Const TPM_RECURSE           As Long = &H1&
  81. Private Const TPM_RETURNCMD         As Long = &H100&
  82. Private Const TPM_RIGHTALIGN        As Long = &H8&
  83. '
  84. '*************************************************************************
  85. '****                                                                 ****
  86. '****    I wanted to give a 'Heads-up' about the BUTTON               ****
  87. '****    parameters.                                                  ****
  88. '****                                                                 ****
  89. '****    TPM_LEFTBUTTON                                               ****
  90. '****    If this flag is set, the user can select menu items with     ****
  91. '****    only the left mouse button.                                  ****
  92. '****                                                                 ****
  93. '****    TPM_RIGHTBUTTON                                              ****
  94. '****    If this flag is set, the user can select menu items with     ****
  95. '****    both the left and right mouse buttons.                       ****
  96. '****                                                                 ****
  97. '****    You might think that TPM_RIGHTBUTTON would select menu       ****
  98. '****    items with the right mouse button but reread                 ****
  99. '****    TPM_RIGHTBUTTON and you will see that this isn't the         ****
  100. '****    case.                                                        ****
  101. '****                                                                 ****
  102. '****    TPM_RIGHTBUTTON allows both the left and right mouse         ****
  103. '****    buttons to be used.  Just a warning...                       ****
  104. '****                                                                 ****
  105. '*************************************************************************
  106. '
  107. Private Const TPM_RIGHTBUTTON       As Long = &H2&
  108. Private Const TPM_TOPALIGN          As Long = &H0&
  109. Private Const TPM_VCENTERALIGN      As Long = &H10&
  110. Private Const TPM_VERNEGANIMATION   As Long = &H2000&
  111. Private Const TPM_VERPOSANIMATION   As Long = &H1000&
  112. Private Const TPM_VERTICAL          As Long = &H40&
  113. '
  114. '*************************************************************************
  115. '****                                                                 ****
  116. '****    POINTAPI is used in the 'TrackPopupMenuEx' Function.         ****
  117. '****                                                                 ****
  118. '*************************************************************************
  119. '
  120. Private Type POINTAPI
  121.     lngX                            As Long
  122.     lngY                            As Long
  123. End Type
  124. '
  125. '*************************************************************************
  126. '****                                                                 ****
  127. '****    These are the Menu Functions.                                ****
  128. '****                                                                 ****
  129. '*************************************************************************
  130. '
  131. 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
  132. Private Declare Function CreatePopupMenu Lib "user32" () As Long
  133. Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
  134. Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
  135. 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
  136.  
  137. Private Sub Form_Load()
  138.  
  139. '   lngBoxNum is used in the 'Color' Sub-Menu
  140.     lngBoxNum = 1
  141.  
  142. End Sub
  143.  
  144. Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  145.  
  146. Dim lngTPM                          As Long
  147. Dim pntXorY                         As POINTAPI
  148. '
  149. '*************************************************************************
  150. '****                                                                 ****
  151. '****    First I'll dimension each of the Menu variables.             ****
  152. '****    The variable will hold the Menu address.                     ****
  153. '****                                                                 ****
  154. '*************************************************************************
  155. '
  156. Dim lngMainMenu                     As Long
  157. Dim lngFirst_Sub_Menu               As Long
  158. Dim lngSecond_Sub_Menu              As Long
  159. '
  160. '   *************************************************************************
  161. '   ****                                                                 ****
  162. '   ****    Then get the address of the Menu.  The variable contains     ****
  163. '   ****    the address.                                                 ****
  164. '   ****                                                                 ****
  165. '   ****    Note:                                                        ****
  166. '   ****    You need to 'CreatePopupMenu' for the Main-Menu and for      ****
  167. '   ****    each Sub-Menu.                                               ****
  168. '   ****                                                                 ****
  169. '   ****    In my example I have my Main-Menu (lngMainMenu) and two      ****
  170. '   ****    Sub-Menus (lngFirst_Sub_Menu) and (lngSecond_Sub_Menu).      ****
  171. '   ****                                                                 ****
  172. '   *************************************************************************
  173. '
  174.     lngMainMenu = CreatePopupMenu()
  175.     lngFirst_Sub_Menu = CreatePopupMenu()
  176.     lngSecond_Sub_Menu = CreatePopupMenu()
  177. '
  178. '   *************************************************************************
  179. '   ****                                                                 ****
  180. '   ****    Save the current Cursor Position.                            ****
  181. '   ****    This will be used to locate the Popup Menu in the            ****
  182. '   ****    'TrackPopupMenuEx' statement.                                ****
  183. '   ****                                                                 ****
  184. '   *************************************************************************
  185. '
  186.     GetCursorPos pntXorY
  187. '
  188. '   *************************************************************************
  189. '   ****                                                                 ****
  190. '   ****    This is the Main-Menu.                                       ****
  191. '   ****                                                                 ****
  192. '   *************************************************************************
  193. '
  194.     AppendMenu lngMainMenu, MF_STRING, 1, "This is the..."
  195.     AppendMenu lngMainMenu, MF_CHECKED, 2, "Main Menu"
  196.     AppendMenu lngMainMenu, MF_SEPARATOR, 3, ByVal 0&
  197. '
  198. '   *************************************************************************
  199. '   ****                                                                 ****
  200. '   ****    The 'MF_POPUP' is the button that will Popup the             ****
  201. '   ****    Sub-Menu.                                                    ****
  202. '   ****                                                                 ****
  203. '   ****    It references the Sub-Menu's identifier                      ****
  204. '   ****    (lngFirst_Sub_Menu).                                         ****
  205. '   ****                                                                 ****
  206. '   *************************************************************************
  207. '
  208.     AppendMenu lngMainMenu, MF_POPUP, lngFirst_Sub_Menu, "More Menus"
  209. '
  210. '   *************************************************************************
  211. '   ****                                                                 ****
  212. '   ****    This is the First Sub-Menu.                                  ****
  213. '   ****                                                                 ****
  214. '   *************************************************************************
  215. '
  216.     AppendMenu lngFirst_Sub_Menu, MF_STRING, 4, "This is an example of..."
  217.     AppendMenu lngFirst_Sub_Menu, MF_SEPARATOR, 5, ByVal 0&
  218. '
  219. '   *************************************************************************
  220. '   ****                                                                 ****
  221. '   ****    The 'MF_POPUP' is the button that will Popup the 'Colors'    ****
  222. '   ****    Sub-Menu (Check-Boxes).                                      ****
  223. '   ****                                                                 ****
  224. '   ****    It references the Sub-Menu's identifier                      ****
  225. '   ****    (lngSecond_Sub_Menu).                                        ****
  226. '   ****                                                                 ****
  227. '   *************************************************************************
  228. '
  229.     AppendMenu lngFirst_Sub_Menu, MF_POPUP, lngSecond_Sub_Menu, "A Sub Menu w/Checked items..."
  230.     AppendMenu lngFirst_Sub_Menu, MF_SEPARATOR, 6, ByVal 0&
  231. '
  232. '   *************************************************************************
  233. '   ****                                                                 ****
  234. '   ****    This is the 'Colors' Sub-Menu w/Check-Boxes.                 ****
  235. '   ****                                                                 ****
  236. '   ****    I replaced the cumbersome "Select Case" routine with this    ****
  237. '   ****    much more compact version.  The  "Select Case" required a    ****
  238. '   ****    line for each Check-Box in each "Case".  In my example,      ****
  239. '   ****    there were 3 Check-Boxes, which meant 3 lines of code 3      ****
  240. '   ****    times, plus the "Select Case" lines.  This isn't a           ****
  241. '   ****    terrible thing, but what if someone wanted to have a         ****
  242. '   ****    Check-Box for each letter of the alphabet?  26 letters,      ****
  243. '   ****    26 times plus "Select Case" code would be over 600 lines     ****
  244. '   ****    of code.  That wouldn't be good, so I came up with the       ****
  245. '   ****    following formula:                                           ****
  246. '   ****                                                                 ****
  247. '   ****    Hex(Abs(lngBoxNum = 1) * 8)                                  ****
  248. '   ****                                                                 ****
  249. '   ****    I take the Check-Box that was selected (lngBoxNum) and do    ****
  250. '   ****    a Boolean check to see if it matches the Check-Box number    ****
  251. '   ****    (the '1' in the formula above).  The Boolean check will      ****
  252. '   ****    return a '-1' if it's true and a '0' if it's false.          ****
  253. '   ****                                                                 ****
  254. '   ****    Next I take the Absolute value of the Boolean check.         ****
  255. '   ****    That leaves me with a '0' or a '1'.                          ****
  256. '   ****                                                                 ****
  257. '   ****    Then I multiply that number by 8 (8 * 0 = 0, 8 * 1 = 8)      ****
  258. '   ****    and convert it to Hex.                                       ****
  259. '   ****                                                                 ****
  260. '   ****    That leaves me with a Hex 8, which is the value of a         ****
  261. '   ****    Checked box (MF_CHECKED) or a Hex 0, which is the value      ****
  262. '   ****    of an unChecked box (MF_UNCHECKED).                          ****
  263. '   ****                                                                 ****
  264. '   ****    Using this formula, if someone wants to have 26              ****
  265. '   ****    Check-Boxes, it will take 26 lines of code.  Much better     ****
  266. '   ****    than 600+ code lines.                                        ****
  267. '   ****                                                                 ****
  268. '   *************************************************************************
  269. '
  270.     AppendMenu lngSecond_Sub_Menu, Hex(Abs(lngBoxNum = 1) * 8), 7, "Red"
  271.     AppendMenu lngSecond_Sub_Menu, Hex(Abs(lngBoxNum = 2) * 8), 8, "Green"
  272.     AppendMenu lngSecond_Sub_Menu, Hex(Abs(lngBoxNum = 3) * 8), 9, "Blue"
  273. '
  274. '   *************************************************************************
  275. '   ****                                                                 ****
  276. '   ****    This is the code that was replaced above.                    ****
  277. '   ****                                                                 ****
  278. '   ****    Select Case lngBoxNum                                        ****
  279. '   ****    Case 1                                                       ****
  280. '   ****    AppendMenu lngSecond_Sub_Menu, MF_CHECKED, 7, "Red"          ****
  281. '   ****    AppendMenu lngSecond_Sub_Menu, MF_UNCHECKED, 8, "Green"      ****
  282. '   ****    AppendMenu lngSecond_Sub_Menu, MF_UNCHECKED, 9, "Blue"       ****
  283. '   ****    Case 2                                                       ****
  284. '   ****    AppendMenu lngSecond_Sub_Menu, MF_UNCHECKED, 7, "Red"        ****
  285. '   ****    AppendMenu lngSecond_Sub_Menu, MF_CHECKED, 8, "Green"        ****
  286. '   ****    AppendMenu lngSecond_Sub_Menu, MF_UNCHECKED, 9, "Blue"       ****
  287. '   ****    Case 3                                                       ****
  288. '   ****    AppendMenu lngSecond_Sub_Menu, MF_UNCHECKED, 7, "Red"        ****
  289. '   ****    AppendMenu lngSecond_Sub_Menu, MF_UNCHECKED, 8, "Green"      ****
  290. '   ****    AppendMenu lngSecond_Sub_Menu, MF_CHECKED, 9, "Blue"         ****
  291. '   ****    End Select  '   lngBoxNum                                    ****
  292. '   ****                                                                 ****
  293. '   *************************************************************************
  294. '
  295.  
  296. '
  297. '   *************************************************************************
  298. '   ****                                                                 ****
  299. '   ****    This is the rest of the First Sub_Menu.                      ****
  300. '   ****                                                                 ****
  301. '   *************************************************************************
  302. '
  303.     AppendMenu lngFirst_Sub_Menu, MF_STRING, 10, "Open the Sub Menu above."
  304.     AppendMenu lngFirst_Sub_Menu, MF_STRING, 11, "Then Click one of the colors."
  305.     AppendMenu lngFirst_Sub_Menu, MF_STRING, 12, "The next time you open it,"
  306.     AppendMenu lngFirst_Sub_Menu, MF_STRING, 13, "your new color will be Checked."
  307.     AppendMenu lngFirst_Sub_Menu, MF_SEPARATOR, 14, ByVal 0&
  308.     AppendMenu lngFirst_Sub_Menu, MF_STRING, 15, "Close"
  309. '
  310. '   *************************************************************************
  311. '   ****                                                                 ****
  312. '   ****    This is the rest of the Main-Menu.                           ****
  313. '   ****                                                                 ****
  314. '   *************************************************************************
  315. '
  316.     AppendMenu lngMainMenu, MF_SEPARATOR, 16, ByVal 0&
  317.     AppendMenu lngMainMenu, MF_STRING, 17, "The next one is"
  318.     AppendMenu lngMainMenu, MF_GRAYED, 18, "Grayed out."
  319. '
  320. '   *************************************************************************
  321. '   ****                                                                 ****
  322. '   ****    The TrackPopupMenuEx function displays a shortcut menu at    ****
  323. '   ****    the specified location and tracks the selection of items     ****
  324. '   ****    on the shortcut menu. The shortcut menu can appear           ****
  325. '   ****    anywhere on the screen. (This definition is from the         ****
  326. '   ****    API-Guide which was created by the KPD team).                ****
  327. '   ****                                                                 ****
  328. '   *************************************************************************
  329. '
  330.     lngTPM = TrackPopupMenuEx(lngMainMenu, TPM_LEFTALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, pntXorY.lngX, pntXorY.lngY, Me.HWnd, ByVal 0&)
  331. '
  332. '   *************************************************************************
  333. '   ****                                                                 ****
  334. '   ****    The DestroyMenu function destroys the specified menu and     ****
  335. '   ****    frees any memory that the menu occupies.                     ****
  336. '   ****                                                                 ****
  337. '   *************************************************************************
  338. '
  339.     DestroyMenu lngMainMenu
  340.     DestroyMenu lngFirst_Sub_Menu
  341.     DestroyMenu lngSecond_Sub_Menu
  342. '
  343. '   *************************************************************************
  344. '   ****                                                                 ****
  345. '   ****    This is where you control the Menu buttons.                  ****
  346. '   ****    This Menu is merely for demonstration purposes so I only     ****
  347. '   ****    included an "End" statement for the Quit button here.        ****
  348. '   ****                                                                 ****
  349. '   *************************************************************************
  350. '
  351.     Select Case lngTPM
  352.         Case 7
  353.             lngBoxNum = 1
  354.         Case 8
  355.             lngBoxNum = 2
  356.         Case 9
  357.             lngBoxNum = 3
  358.         Case 15
  359.             End
  360.     End Select  '   lngTPM
  361.  
  362. End Sub
  363.