home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / VirtualDig6926546200.psc / cMenuBar.cls < prev    next >
Encoding:
Visual Basic class definition  |  2002-01-04  |  40.2 KB  |  1,153 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cMenuBar"
  10. Attribute VB_GlobalNameSpace = True
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. ' =======================================================================
  17. ' MENU private declares:
  18. ' =======================================================================
  19.  
  20. ' Menu flag constants:
  21. Private Const MF_APPEND = &H100&
  22. Private Const MF_BITMAP = &H4&
  23. Private Const MF_BYCOMMAND = &H0&
  24. Private Const MF_BYPOSITION = &H400&
  25. Private Const MF_CALLBACKS = &H8000000
  26. Private Const MF_CHANGE = &H80&
  27. Private Const MF_CHECKED = &H8&
  28. Private Const MF_CONV = &H40000000
  29. Private Const MF_DELETE = &H200&
  30. Private Const MF_DISABLED = &H2&
  31. Private Const MF_ENABLED = &H0&
  32. Private Const MF_END = &H80
  33. Private Const MF_ERRORS = &H10000000
  34. Private Const MF_GRAYED = &H1&
  35. Private Const MF_HELP = &H4000&
  36. Private Const MF_HILITE = &H80&
  37. Private Const MF_HSZ_INFO = &H1000000
  38. Private Const MF_INSERT = &H0&
  39. Private Const MF_LINKS = &H20000000
  40. Private Const MF_MASK = &HFF000000
  41. Private Const MF_MENUBARBREAK = &H20&
  42. Private Const MF_MENUBREAK = &H40&
  43. Private Const MF_MOUSESELECT = &H8000&
  44. Private Const MF_OWNERDRAW = &H100&
  45. Private Const MF_POPUP = &H10&
  46. Private Const MF_POSTMSGS = &H4000000
  47. Private Const MF_REMOVE = &H1000&
  48. Private Const MF_SENDMSGS = &H2000000
  49. Private Const MF_SEPARATOR = &H800&
  50. Private Const MF_STRING = &H0&
  51. Private Const MF_SYSMENU = &H2000&
  52. Private Const MF_UNCHECKED = &H0&
  53. Private Const MF_UNHILITE = &H0&
  54. Private Const MF_USECHECKBITMAPS = &H200&
  55. Private Const MF_DEFAULT = &H1000&
  56.  
  57. Private Const MFT_STRING = MF_STRING
  58. Private Const MFT_BITMAP = MF_BITMAP
  59. Private Const MFT_MENUBARBREAK = MF_MENUBARBREAK
  60. Private Const MFT_MENUBREAK = MF_MENUBREAK
  61. Private Const MFT_OWNERDRAW = MF_OWNERDRAW
  62. Private Const MFT_RADIOCHECK = &H200&
  63. Private Const MFT_SEPARATOR = MF_SEPARATOR
  64. Private Const MFT_RIGHTORDER = &H2000&
  65.  
  66. ' New versions of the names...
  67. Private Const MFS_GRAYED = &H3&
  68. Private Const MFS_DISABLED = MFS_GRAYED
  69. Private Const MFS_CHECKED = MF_CHECKED
  70. Private Const MFS_HILITE = MF_HILITE
  71. Private Const MFS_ENABLED = MF_ENABLED
  72. Private Const MFS_UNCHECKED = MF_UNCHECKED
  73. Private Const MFS_UNHILITE = MF_UNHILITE
  74. Private Const MFS_DEFAULT = MF_DEFAULT
  75.  
  76. ' MenuItemInfo Mask constants
  77. Private Const MIIM_STATE = &H1&
  78. Private Const MIIM_ID = &H2&
  79. Private Const MIIM_SUBMENU = &H4&
  80. Private Const MIIM_CHECKMARKS = &H8&
  81. Private Const MIIM_TYPE = &H10&
  82. Private Const MIIM_DATA = &H20&
  83.  
  84. Private Const SC_RESTORE = &HF120&
  85. Private Const SC_MOVE = &HF010&
  86. Private Const SC_SIZE = &HF000&
  87. Private Const SC_MAXIMIZE = &HF030&
  88. Private Const SC_MINIMIZE = &HF020&
  89. Private Const SC_CLOSE = &HF060&
  90.      
  91. Private Const SC_ARRANGE = &HF110&
  92. Private Const SC_HOTKEY = &HF150&
  93. Private Const SC_HSCROLL = &HF080&
  94. Private Const SC_KEYMENU = &HF100&
  95. Private Const SC_MOUSEMENU = &HF090&
  96. Private Const SC_NEXTWINDOW = &HF040&
  97. Private Const SC_PREVWINDOW = &HF050&
  98. Private Const SC_SCREENSAVE = &HF140&
  99. Private Const SC_TASKLIST = &HF130&
  100. Private Const SC_VSCROLL = &HF070&
  101. Private Const SC_ZOOM = SC_MAXIMIZE
  102. Private Const SC_ICON = SC_MINIMIZE
  103.  
  104. ' Owner draw information:
  105. Private Const ODS_CHECKED = &H8
  106. Private Const ODS_DISABLED = &H4
  107. Private Const ODS_FOCUS = &H10
  108. Private Const ODS_GRAYED = &H2
  109. Private Const ODS_SELECTED = &H1
  110. Private Const ODT_BUTTON = 4
  111. Private Const ODT_COMBOBOX = 3
  112. Private Const ODT_LISTBOX = 2
  113. Private Const ODT_MENU = 1
  114.  
  115. Private Type MEASUREITEMSTRUCT
  116.    CtlType As Long
  117.    CtlID As Long
  118.    itemID As Long
  119.    itemWidth As Long
  120.    itemHeight As Long
  121.    ItemData As Long
  122. End Type
  123.  
  124. Private Type DRAWITEMSTRUCT
  125.    CtlType As Long
  126.    CtlID As Long
  127.    itemID As Long
  128.    itemAction As Long
  129.    itemState As Long
  130.    hwndItem As Long
  131.    hdc As Long
  132.    rcItem As RECT
  133.    ItemData As Long
  134. End Type
  135.  
  136. Private Type MENUITEMINFO
  137.    cbSize As Long
  138.    fMask As Long
  139.    fType As Long
  140.    fState As Long
  141.    wID As Long
  142.    hSubMenu As Long
  143.    hbmpChecked As Long
  144.    hbmpUnchecked As Long
  145.    dwItemData As Long
  146.    dwTypeData As Long
  147.    cch As Long
  148. End Type
  149. Private Type MENUITEMINFO_STRINGDATA
  150.    cbSize As Long
  151.    fMask As Long
  152.    fType As Long
  153.    fState As Long
  154.    wID As Long
  155.    hSubMenu As Long
  156.    hbmpChecked As Long
  157.    hbmpUnchecked As Long
  158.    dwItemData As Long
  159.    dwTypeData As String
  160.    cch As Long
  161. End Type
  162.  
  163. Private Type MENUITEMTEMPLATE
  164.    mtOption As Integer
  165.    mtID As Integer
  166.    mtString As Byte
  167. End Type
  168. Private Type MENUITEMTEMPLATEHEADER
  169.    versionNumber As Integer
  170.    Offset As Integer
  171. End Type
  172.  
  173. Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
  174. Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
  175. Private Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long
  176.  
  177. Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
  178. Private Declare Function GetMenuCheckMarkDimensions Lib "user32" () As Long
  179. Private Declare Function GetMenuContextHelpId Lib "user32" (ByVal hMenu As Long) As Long
  180. Private Declare Function GetMenuDefaultItem Lib "user32" (ByVal hMenu As Long, ByVal fByPos As Long, ByVal gmdiFlags As Long) As Long
  181. Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
  182. Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Boolean, lpMenuItemInfo As MENUITEMINFO) As Long
  183. Private Declare Function GetMenuItemInfoStr Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Boolean, lpMenuItemInfo As MENUITEMINFO_STRINGDATA) As Long
  184. Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
  185. Private Declare Function SetMenuItemInfoStr Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO_STRINGDATA) As Long
  186. Private Declare Function GetMenuItemRect Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long, ByVal uItem As Long, lprcItem As RECT) As Long
  187. Private Declare Function GetMenuState Lib "user32" (ByVal hMenu As Long, ByVal wID As Long, ByVal wFlags As Long) As Long
  188.  
  189. Private Declare Function CreateMenu Lib "user32" () As Long
  190. Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
  191. Private Declare Function CreatePopupMenu Lib "user32" () As Long
  192.  
  193. Private Declare Function AppendMenuBylong Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Long) As Long
  194. Private Declare Function AppendMenuByString Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
  195. Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
  196. Private Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
  197. Private Declare Function ModifyMenuByLong Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Long) As Long
  198. Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
  199. Private Declare Function InsertMenuByLong Lib "user32" Alias "InsertMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Long) As Long
  200. Private Declare Function InsertMenuByString Lib "user32" Alias "InsertMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
  201. Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
  202.  
  203. Private Declare Function CheckMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDCheckItem As Long, ByVal wCheck As Long) As Long
  204. Private Declare Function CheckMenuRadioItem Lib "user32" (ByVal hMenu As Long, ByVal un1 As Long, ByVal un2 As Long, ByVal un3 As Long, ByVal un4 As Long) As Long
  205. Private Declare Function EnableMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
  206. Private Declare Function HiliteMenuItem Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long, ByVal wIDHiliteItem As Long, ByVal wHilite As Long) As Long
  207.  
  208. Private Declare Function MenuItemFromPoint Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long, ByVal ptScreen As POINTAPI) As Long
  209. Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
  210.  
  211. ' =======================================================================
  212. ' GDI private declares:
  213. ' =======================================================================
  214.  
  215. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  216. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  217. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  218. Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
  219. Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
  220. Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
  221. Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
  222. Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
  223. Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
  224. Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
  225. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  226. Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  227.  
  228. Private Const DT_BOTTOM = &H8
  229. Private Const DT_CENTER = &H1
  230. Private Const DT_LEFT = &H0
  231. Private Const DT_CALCRECT = &H400
  232. Private Const DT_WORDBREAK = &H10
  233. Private Const DT_VCENTER = &H4
  234. Private Const DT_TOP = &H0
  235. Private Const DT_TABSTOP = &H80
  236. Private Const DT_SINGLELINE = &H20
  237. Private Const DT_RIGHT = &H2
  238. Private Const DT_NOCLIP = &H100
  239. Private Const DT_INTERNAL = &H1000
  240. Private Const DT_EXTERNALLEADING = &H200
  241. Private Const DT_EXPANDTABS = &H40
  242. Private Const DT_CHARSTREAM = 4
  243. Private Const DT_NOPREFIX = &H800
  244. Private Const DT_EDITCONTROL = &H2000&
  245. Private Const DT_PATH_ELLIPSIS = &H4000&
  246. Private Const DT_END_ELLIPSIS = &H8000&
  247. Private Const DT_MODIFYSTRING = &H10000
  248. Private Const DT_RTLREADING = &H20000
  249. Private Const DT_WORD_ELLIPSIS = &H40000
  250.  
  251. Private Const OPAQUE = 2
  252. Private Const TRANSPARENT = 1
  253.  
  254. ' DrawEdge:
  255. Private Const BDR_RAISEDOUTER = &H1
  256. Private Const BDR_SUNKENOUTER = &H2
  257. Private Const BDR_RAISEDINNER = &H4
  258. Private Const BDR_SUNKENINNER = &H8
  259.  
  260. Private Const BDR_OUTER = &H3
  261. Private Const BDR_INNER = &HC
  262. Private Const BDR_RAISED = &H5
  263. Private Const BDR_SUNKEN = &HA
  264.  
  265. Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
  266. Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
  267. Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
  268. Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)
  269.  
  270. Private Const BF_LEFT = &H1
  271. Private Const BF_TOP = &H2
  272. Private Const BF_RIGHT = &H4
  273. Private Const BF_BOTTOM = &H8
  274.  
  275. Private Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
  276. Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
  277. Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
  278. Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
  279. Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
  280.  
  281. Private Const CLR_INVALID = -1
  282.  
  283.  
  284. ' =======================================================================
  285. ' General Win private declares:
  286. ' =======================================================================
  287. Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
  288. Private Declare Function MapWindowPoints Lib "user32" (ByVal hwndFrom As Long, ByVal hwndTo As Long, lppt As Any, ByVal cPoints As Long) As Long
  289. Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
  290. Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
  291. Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
  292. Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  293. Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
  294. Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  295.  
  296. Private Const HWND_DESKTOP = 0
  297.  
  298.  
  299. ' =======================================================================
  300. ' IMPLEMENTATION
  301. ' =======================================================================
  302.  
  303. Private m_cMemDC As cMemDC
  304. Private m_cToolbarMenu As cToolbarMenu
  305. Private m_hMenu As Long
  306. Private m_hWnd As Long
  307.  
  308. Private m_tR() As RECT
  309. Private m_hSubMenu() As Long
  310. Private m_iCount As Long
  311. Private m_iDownOn As Long
  312. Private m_iOver As Long
  313.  
  314. Private m_oActiveMenuColor As OLE_COLOR
  315. Private m_oActiveMenuColorOver As OLE_COLOR
  316. Private m_oInActiveMenuColor As OLE_COLOR
  317.  
  318. Private m_oMenuBackgroundColor As OLE_COLOR
  319.  
  320. Private m_lCaptionHeight As Long
  321.  
  322. Private m_iRestore As Long
  323. Private m_hMenuRestore() As Long
  324. Private m_iMenuPosition() As Long
  325. Private m_tMIIS() As MENUITEMINFO_STRINGDATA
  326. Private m_sCaption() As String
  327. Private m_sShortCut() As String
  328. Private m_sAccelerator() As String
  329. Private m_lMenuTextSize() As Long
  330. Private m_lMenuShortCutSize() As Long
  331.  
  332. Private m_iHaveSeenCount As Long
  333. Private m_hMenuSeen() As Long
  334.  
  335. Private m_fnt As StdFont
  336. Private m_fntSymbol As StdFont
  337.  
  338. Private m_lMenuItemHeight As Long
  339.  
  340. Private WithEvents m_cTmr As CTimer
  341. Attribute m_cTmr.VB_VarHelpID = -1
  342.  
  343. Implements ISubclass
  344.  
  345. Friend Property Let Font( _
  346.       fntThis As StdFont _
  347.    )
  348.    Set m_fnt = fntThis
  349. End Property
  350. Friend Property Set Font( _
  351.       fntThis As StdFont _
  352.    )
  353.    Set m_fnt = fntThis
  354.    m_fntSymbol.Name = "Marlett"
  355.    m_fntSymbol.Size = m_fnt.Size * 1.2
  356. End Property
  357. Friend Property Get Font() As StdFont
  358.    Set Font = m_fnt
  359. End Property
  360. Friend Sub SetColors( _
  361.       ByVal oActiveMenuColor As OLE_COLOR, _
  362.       ByVal oActiveMenuColorOver As OLE_COLOR, _
  363.       ByVal oInActiveMenuColor As OLE_COLOR, _
  364.       ByVal oMenuBackgroundColor As OLE_COLOR _
  365.    )
  366.    m_oActiveMenuColor = oActiveMenuColor
  367.    m_oActiveMenuColorOver = oActiveMenuColorOver
  368.    m_oInActiveMenuColor = oInActiveMenuColor
  369.    m_oMenuBackgroundColor = oMenuBackgroundColor
  370. End Sub
  371. Private Property Get hFont() As Long
  372. Dim iFn As IFont
  373.    Set iFn = m_fnt
  374.    hFont = iFn.hFont
  375. End Property
  376. Private Property Get hFontSymbol() As Long
  377. Dim iFn As IFont
  378.    Set iFn = m_fntSymbol
  379.    hFontSymbol = iFn.hFont
  380. End Property
  381.  
  382. Public Property Let hMenu(ByVal hTheMenu As Long)
  383.    m_hMenu = hTheMenu
  384. End Property
  385. Public Property Get hMenu() As Long
  386.    hMenu = m_hMenu
  387. End Property
  388. Public Sub Attach(ByVal lhWnd As Long)
  389.    Detach
  390.    m_hWnd = lhWnd
  391.    Set m_cToolbarMenu = New cToolbarMenu
  392.    m_cToolbarMenu.CoolMenuAttach m_hWnd, Me
  393.    AttachMessage Me, m_hWnd, WM_LBUTTONDOWN
  394.    AttachMessage Me, m_hWnd, WM_MOUSEMOVE
  395.    AttachMessage Me, m_hWnd, WM_DRAWITEM
  396.    AttachMessage Me, m_hWnd, WM_MEASUREITEM
  397.    AttachMessage Me, m_hWnd, WM_MENUCHAR
  398. End Sub
  399. Public Sub Detach()
  400.    If Not m_hWnd = 0 Then
  401.       DetachMessage Me, m_hWnd, WM_LBUTTONDOWN
  402.       DetachMessage Me, m_hWnd, WM_MOUSEMOVE
  403.       DetachMessage Me, m_hWnd, WM_DRAWITEM
  404.       DetachMessage Me, m_hWnd, WM_MEASUREITEM
  405.       DetachMessage Me, m_hWnd, WM_MENUCHAR
  406.    End If
  407.    If Not m_cToolbarMenu Is Nothing Then
  408.       m_cToolbarMenu.CoolMenuDetach
  409.       Set m_cToolbarMenu = Nothing
  410.    End If
  411. End Sub
  412. Public Property Let CaptionHeight(ByVal lHeight As Long)
  413.    m_lCaptionHeight = lHeight
  414. End Property
  415.  
  416. Public Sub Render( _
  417.       ByVal hFnt As Long, _
  418.       ByVal lhDC As Long, _
  419.       ByVal lLeft As Long, _
  420.       ByVal lTop As Long, _
  421.       ByVal lWidth As Long, _
  422.       ByVal lHeight As Long, _
  423.       ByVal lYoffset As Long _
  424.    )
  425. Dim iIdx As Long
  426. Dim lC As Long
  427. Dim lhDCC As Long
  428. Dim tMII As MENUITEMINFO_STRINGDATA
  429. Dim sCap As String
  430. Dim hFntOld As Long
  431. Dim tTR As RECT, tBR As RECT
  432. Dim lX As Long
  433. Dim lR As Long
  434. Dim bPress As Boolean
  435. Dim lID As Long
  436.  
  437.    If Not (m_hMenu = 0) Then
  438.       m_cMemDC.Width = lWidth
  439.       m_cMemDC.Height = lHeight
  440.       lhDCC = m_cMemDC.hdc
  441.  
  442.       hFntOld = SelectObject(lhDCC, hFnt)
  443.       m_iCount = 0
  444.       Erase m_tR
  445.  
  446.       lC = GetMenuItemCount(m_hMenu)
  447.       If lC > 0 Then
  448.          lX = 8
  449.          lTop = lTop + 2
  450.          BitBlt lhDCC, 0, 0, lWidth, lHeight, lhDC, lLeft, lTop, vbSrcCopy
  451.          SetBkMode lhDCC, TRANSPARENT
  452.          For iIdx = 0 To lC - 1
  453.             lID = GetMenuItemID(m_hMenu, iIdx)
  454.             If lID = -1 Then
  455.                tMII.fMask = MIIM_TYPE
  456.                tMII.cch = 127
  457.                tMII.dwTypeData = String$(128, 0)
  458.                tMII.cbSize = LenB(tMII)
  459.                lR = GetMenuItemInfoStr(m_hMenu, iIdx, True, tMII)
  460.                If (tMII.fType And MFT_STRING) = MFT_STRING Then
  461.                   If tMII.cch > 0 Then
  462.                      sCap = left$(tMII.dwTypeData, tMII.cch)
  463.                   Else
  464.                      sCap = ""
  465.                   End If
  466.                   tTR.top = 0
  467.                   tTR.bottom = lHeight
  468.                   tTR.left = 0: tTR.right = 0
  469.                   DrawText lhDCC, sCap, -1, tTR, DT_CALCRECT
  470.                   OffsetRect tTR, lX, 2
  471.                   LSet tBR = tTR
  472.                   InflateRect tBR, 2, 2
  473.                   tBR.right = tBR.right + 7
  474.                   m_iCount = m_iCount + 1
  475.                   bPress = False
  476.                   If m_iCount = m_iDownOn Then
  477.                      ' This is the item that was clicked:
  478.                      If m_iDownOn = m_iOver Then
  479.                         ' Draw Pressed
  480.                         'Debug.Print "DrawPressed"
  481.                         bPress = True
  482.                         SetTextColor lhDCC, TranslateColor(m_oActiveMenuColorOver)
  483.                         DrawEdge lhDCC, tBR, BDR_SUNKENOUTER, BF_RECT
  484.                      Else
  485.                         ' Draw Raised
  486.                         'Debug.Print "DrawRaised"
  487.                         SetTextColor lhDCC, TranslateColor(m_oActiveMenuColorOver)
  488.                         DrawEdge lhDCC, tBR, BDR_RAISEDINNER, BF_RECT
  489.                      End If
  490.                   Else
  491.                      ' Not down on, may be over:
  492.                      If m_iCount = m_iOver Then
  493.                         ' Draw Raised
  494.                         'Debug.Print "DrawRaised"
  495.                         SetTextColor lhDCC, TranslateColor(m_oActiveMenuColorOver)
  496.                         DrawEdge lhDCC, tBR, BDR_RAISEDINNER, BF_RECT
  497.                      Else
  498.                         ' Draw None
  499.                         SetTextColor lhDCC, TranslateColor(m_oActiveMenuColor)
  500.                      End If
  501.                   End If
  502.                   If bPress Then
  503.                      OffsetRect tTR, 1, 1
  504.                   End If
  505.                   DrawText lhDCC, sCap, -1, tTR, DT_LEFT Or DT_SINGLELINE
  506.                   If bPress Then
  507.                      OffsetRect tTR, -1, -1
  508.                   End If
  509.                   ReDim Preserve m_tR(1 To m_iCount) As RECT
  510.                   ReDim Preserve m_hSubMenu(1 To m_iCount) As Long
  511.                   OffsetRect tBR, lLeft, lYoffset
  512.                   LSet m_tR(m_iCount) = tBR
  513.                   m_hSubMenu(m_iCount) = GetSubMenu(m_hMenu, iIdx)
  514.                   lX = lX + tTR.right - tTR.left + 1 + 10
  515.                End If
  516.             End If
  517.          Next iIdx
  518.  
  519.          BitBlt lhDC, lLeft, lTop, lWidth, lHeight, lhDCC, 0, 0, vbSrcCopy
  520.  
  521.       End If
  522.    
  523.       SelectObject lhDCC, hFntOld
  524.    End If
  525. End Sub
  526. Friend Function AltKeyAccelerator(ByVal vKey As KeyCodeConstants) As Boolean
  527. Dim lC As Long
  528. Dim iIdx As Long
  529. Dim tMII As MENUITEMINFO_STRINGDATA
  530. Dim lR As Long
  531. Dim sCap As String
  532. Dim iPos As Long
  533. Dim sAccel As String
  534.  
  535.    lC = GetMenuItemCount(m_hMenu)
  536.    If lC > 0 Then
  537.       For iIdx = 0 To lC - 1
  538.          tMII.fMask = MIIM_TYPE Or MIIM_DATA
  539.          tMII.cch = 127
  540.          tMII.dwTypeData = String$(128, 0)
  541.          tMII.cbSize = LenB(tMII)
  542.          lR = GetMenuItemInfoStr(m_hMenu, iIdx, True, tMII)
  543.          If tMII.cch > 0 Then
  544.             sCap = left$(tMII.dwTypeData, tMII.cch)
  545.             iPos = InStr(sCap, "&")
  546.             If iPos > 0 And iPos < Len(sCap) Then
  547.                sAccel = UCase$(Mid$(sCap, iPos + 1, 1))
  548.                If sAccel = Chr$(vKey) Then
  549.                   PressButton iIdx + 1, True
  550.                   If Not m_cTmr Is Nothing Then
  551.                      m_cTmr.Interval = 0
  552.                   End If
  553.                   lR = m_cToolbarMenu.TrackPopup(m_iDownOn)
  554.                   pRestoreList
  555.                   AltKeyAccelerator = True
  556.                End If
  557.             End If
  558.          End If
  559.       Next iIdx
  560.    End If
  561. End Function
  562. Private Function MenuHitTest() As Long
  563.  
  564.    If m_iCount > 0 Then
  565.       Dim tP As POINTAPI
  566.       GetCursorPos tP
  567.       MenuHitTest = HitTest(tP)
  568.    End If
  569.    
  570. End Function
  571. Friend Function HitTest(tP As POINTAPI) As Long
  572.  
  573.    ' Is tP within a top level menu button? tP
  574.    ' is in screen coords
  575.    '
  576. Dim iMenu As Long
  577.  
  578.    ScreenToClient m_hWnd, tP
  579.    For iMenu = 1 To m_iCount
  580.       'Debug.Print m_tR(iMenu).left, m_tR(iMenu).top, m_tR(iMenu).right, m_tR(iMenu).bottom, tP.x, tP.y
  581.       If PtInRect(m_tR(iMenu), tP.x, tP.y) <> 0 Then
  582.          HitTest = iMenu
  583.          Exit Function
  584.       End If
  585.    Next iMenu
  586. End Function
  587. Friend Property Get Count() As Long
  588.    
  589.    ' Number of top level menu items:?
  590.    '
  591.    Count = m_iCount
  592.    
  593. End Property
  594. Friend Function GetMenuHandle(ByVal iNewPopup As Long) As Long
  595.    
  596.    ' Returns the popup menu handle for a given top level
  597.    ' menu item (1 based index)
  598.    '
  599.    If iNewPopup > 0 And iNewPopup <= m_iCount Then
  600.       GetMenuHandle = m_hSubMenu(iNewPopup)
  601.    End If
  602. End Function
  603. Friend Sub PressButton(ByVal iButton As Long, ByVal bState As Boolean)
  604.    '
  605.    If bState Then
  606.       m_iDownOn = iButton
  607.    Else
  608.       If m_iDownOn = iButton Then
  609.          m_iDownOn = -1
  610.       End If
  611.    End If
  612.    SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
  613.    
  614. End Sub
  615. Friend Sub GetRect(ByVal iButton As Long, ByRef tR As RECT)
  616. Dim tRW As RECT
  617.    If iButton > 0 And iButton <= m_iCount Then
  618.       LSet tR = m_tR(iButton)
  619.       GetWindowRect m_hWnd, tRW
  620.       OffsetRect tR, tRW.left, tRW.top + m_lCaptionHeight
  621.    End If
  622. End Sub
  623. Friend Property Get HotItem() As Long
  624.    '
  625.    HotItem = m_iDownOn
  626. End Property
  627. Friend Property Let HotItem(ByVal iHotItem As Long)
  628.    ' Set the hotitem
  629.    m_iOver = iHotItem
  630.    ' Repaint:
  631.    SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
  632. End Property
  633.  
  634. Friend Sub OwnerDrawMenu(ByVal hMenu As Long)
  635. Dim lC As Long
  636. Dim tMIIS As MENUITEMINFO_STRINGDATA
  637. Dim tMII As MENUITEMINFO
  638. Dim iMenu As Long
  639. Dim sCap As String
  640. Dim sShortCut As String
  641. Dim tR As RECT
  642. Dim iPos As Long
  643. Dim lID As Long
  644. Dim bHaveSeen As Boolean
  645. Dim hFntOld As Long
  646. Dim lMenuTextSize As Long
  647. Dim lMenuShortCutSize As Long
  648. Dim i As Long
  649.                   
  650.    ' Set OD flag on the fly...
  651.    bHaveSeen = pbHaveSeen(hMenu)
  652.  
  653.    hFntOld = SelectObject(m_cMemDC.hdc, hFont)
  654.    lC = GetMenuItemCount(hMenu)
  655.    For iMenu = 0 To lC - 1
  656.       
  657.       If Not bHaveSeen Then
  658.                
  659.          tMIIS.fMask = MIIM_TYPE Or MIIM_DATA Or MIIM_ID
  660.          tMIIS.cch = 127
  661.          tMIIS.dwTypeData = String$(128, 0)
  662.          tMIIS.cbSize = LenB(tMIIS)
  663.          GetMenuItemInfoStr hMenu, iMenu, True, tMIIS
  664.          'Debug.Print "New Item", tMIIS.dwTypeData
  665.          
  666.          lID = plAddToRestoreList(hMenu, iMenu, tMIIS)
  667.       
  668.          If Not (tMIIS.fType And MFT_OWNERDRAW) = MFT_OWNERDRAW Then
  669.             ' Setting this flag causes tMIIS.dwTypeData to be
  670.             ' overwritten with our own app-defined value:
  671.             tMII.fType = tMIIS.fType Or MFT_OWNERDRAW
  672.             tMII.dwItemData = lID
  673.             tMII.cbSize = LenB(tMII)
  674.             tMII.fMask = MIIM_TYPE Or MIIM_DATA
  675.             SetMenuItemInfo hMenu, iMenu, True, tMII
  676.          End If
  677.       
  678.       Else
  679.          
  680.          tMII.fMask = MIIM_TYPE Or MIIM_DATA
  681.          tMII.cbSize = Len(tMII)
  682.          GetMenuItemInfo hMenu, iMenu, True, tMII
  683.          lID = tMII.dwItemData
  684.          
  685.          If Not ((tMII.fType And MFT_OWNERDRAW) = MFT_OWNERDRAW) Then
  686.             
  687.             lID = plReplaceIndex(hMenu, iMenu)
  688.          
  689.             'Debug.Print "VB has done something to it!", lID
  690.             tMIIS.fMask = MIIM_TYPE Or MIIM_DATA Or MIIM_ID
  691.             tMIIS.cch = 127
  692.             tMIIS.dwTypeData = String$(128, 0)
  693.             tMIIS.cbSize = LenB(tMIIS)
  694.             GetMenuItemInfoStr hMenu, iMenu, True, tMIIS
  695.             
  696.             pReplaceRestoreList lID, hMenu, iMenu, tMIIS
  697.             
  698.             ' Setting this flag causes tMIIS.dwTypeData to be
  699.             ' overwritten with our own app-defined value:
  700.             tMII.fType = tMIIS.fType Or MFT_OWNERDRAW
  701.             tMII.dwItemData = lID
  702.             tMII.cbSize = LenB(tMII)
  703.             tMII.fMask = MIIM_TYPE Or MIIM_DATA
  704.             SetMenuItemInfo hMenu, iMenu, True, tMII
  705.             
  706.          End If
  707.          
  708.       End If
  709.                               
  710.       If lID > 0 And lID <= m_iRestore Then
  711.          sCap = m_sCaption(lID)
  712.          sShortCut = m_sShortCut(lID)
  713.          
  714.          'Debug.Print m_sCaption(lID), m_sShortCut(lID)
  715.          
  716.          DrawText m_cMemDC.hdc, sCap, -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_CALCRECT
  717.          If tR.right - tR.left + 1 > lMenuTextSize Then
  718.             lMenuTextSize = tR.right - tR.left + 1
  719.          End If
  720.          If Len(sShortCut) > 0 Then
  721.             DrawText m_cMemDC.hdc, sShortCut, -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_CALCRECT
  722.             If tR.right - tR.left + 1 > lMenuShortCutSize Then
  723.                lMenuShortCutSize = tR.right - tR.left + 1
  724.             End If
  725.          End If
  726.          m_lMenuItemHeight = tR.bottom - tR.top + 1
  727.          
  728.       Else
  729.          'Debug.Print "ERROR! ERROR! ERROR!"
  730.       End If
  731.       
  732.    Next iMenu
  733.    
  734.    For i = 1 To m_iRestore
  735.       If m_hMenuRestore(i) = hMenu Then
  736.          m_lMenuTextSize(i) = lMenuTextSize
  737.          m_lMenuShortCutSize(i) = lMenuShortCutSize
  738.       End If
  739.    Next i
  740.    
  741.    SelectObject m_cMemDC.hdc, hFntOld
  742.    
  743. End Sub
  744. Private Function pbHaveSeen(ByVal hMenu As Long) As Boolean
  745.    
  746.    ' When WM_INITMENUPOPUP fires, this may or not be
  747.    ' a new menu.  We use an array to store which menus
  748.    ' we've already worked on:
  749.  
  750. Dim i As Long
  751.    
  752.    For i = 1 To m_iHaveSeenCount
  753.       If hMenu = m_hMenuSeen(i) Then
  754.          pbHaveSeen = True
  755.          Exit Function
  756.       End If
  757.    Next i
  758.    m_iHaveSeenCount = m_iHaveSeenCount + 1
  759.    ReDim Preserve m_hMenuSeen(1 To m_iHaveSeenCount) As Long
  760.    m_hMenuSeen(m_iHaveSeenCount) = hMenu
  761.  
  762. End Function
  763. Private Function plReplaceIndex(ByVal hMenu As Long, ByVal iMenu As Long)
  764. Dim i As Long
  765.    For i = 1 To m_iRestore
  766.       If m_hMenuRestore(i) = hMenu Then
  767.          If m_iMenuPosition(i) = iMenu Then
  768.             plReplaceIndex = i
  769.             Exit Function
  770.          End If
  771.       End If
  772.    Next i
  773. End Function
  774. Private Function plAddToRestoreList(ByVal hMenu As Long, ByVal iMenu As Long, tMIIS As MENUITEMINFO_STRINGDATA) As Long
  775.    
  776.    ' Here we store information about a menu item.  When the
  777.    ' menus are closed again we can reset things back to the
  778.    ' way they were using this struct.
  779.  
  780.    m_iRestore = m_iRestore + 1
  781.    ReDim Preserve m_hMenuRestore(1 To m_iRestore) As Long
  782.    ReDim Preserve m_iMenuPosition(1 To m_iRestore) As Long
  783.    ReDim Preserve m_tMIIS(1 To m_iRestore) As MENUITEMINFO_STRINGDATA
  784.    ReDim Preserve m_sCaption(1 To m_iRestore) As String
  785.    ReDim Preserve m_sShortCut(1 To m_iRestore) As String
  786.    ReDim Preserve m_sAccelerator(1 To m_iRestore) As String
  787.    ReDim Preserve m_lMenuTextSize(1 To m_iRestore) As Long
  788.    ReDim Preserve m_lMenuShortCutSize(1 To m_iRestore) As Long
  789.    pReplaceRestoreList m_iRestore, hMenu, iMenu, tMIIS
  790.    plAddToRestoreList = m_iRestore
  791.  
  792. End Function
  793. Private Sub pReplaceRestoreList(ByVal lIdx As Long, hMenu As Long, iMenu As Long, tMIIS As MENUITEMINFO_STRINGDATA)
  794. Dim sCap As String
  795. Dim sShortCut As String
  796. Dim iPos As Long
  797.  
  798.    m_hMenuRestore(lIdx) = hMenu
  799.    m_iMenuPosition(lIdx) = iMenu
  800.    LSet m_tMIIS(lIdx) = tMIIS
  801.    If tMIIS.cch > 0 Then
  802.       sCap = left$(tMIIS.dwTypeData, tMIIS.cch)
  803.    Else
  804.       sCap = ""
  805.    End If
  806.    iPos = InStr(sCap, vbTab)
  807.    If iPos > 0 Then
  808.       m_sShortCut(lIdx) = Mid$(sCap, iPos + 1)
  809.       m_sCaption(lIdx) = left$(sCap, iPos - 1)
  810.    Else
  811.       m_sCaption(lIdx) = sCap
  812.       m_sShortCut(lIdx) = ""
  813.    End If
  814.    iPos = InStr(m_sCaption(lIdx), "&")
  815.    If iPos > 0 And iPos < Len(m_sCaption(lIdx)) Then
  816.       m_sAccelerator(lIdx) = UCase$(Mid$(m_sCaption(lIdx), iPos + 1, 1))
  817.    End If
  818. End Sub
  819. Private Function InternalIDForWindowsID(ByVal wID As Long) As Long
  820. Dim i As Long
  821.    ' linear search I'm afraid, but it is only called once
  822.    ' per menu item shown (when WM_MEASUREITEM is fired)
  823.    For i = 1 To m_iRestore
  824.       If m_tMIIS(i).wID = wID Then
  825.          InternalIDForWindowsID = i
  826.          Exit Function
  827.       End If
  828.    Next i
  829. End Function
  830. Friend Sub pRestoreList()
  831. Dim i As Long
  832.    'Debug.Print "RESTORELIST"
  833.    ' erase the lot:
  834.    For i = 1 To m_iRestore
  835.       SetMenuItemInfoStr m_hMenuRestore(i), m_iMenuPosition(i), True, m_tMIIS(i)
  836.    Next i
  837.    m_iRestore = 0
  838.    Erase m_hMenuRestore
  839.    Erase m_iMenuPosition
  840.    Erase m_tMIIS
  841.    Erase m_sCaption()
  842.    Erase m_sShortCut()
  843.    Erase m_sAccelerator()
  844.    m_iHaveSeenCount = 0
  845.    Erase m_hMenuSeen()
  846. End Sub
  847.  
  848. Private Sub Class_Initialize()
  849.    Set m_cMemDC = New cMemDC
  850.    Set m_fnt = New StdFont
  851.    m_fnt.Name = "MS Sans Serif"
  852.    Set m_fntSymbol = New StdFont
  853.    m_fntSymbol.Name = "Marlett"
  854.    m_fntSymbol.Size = m_fnt.Size * 1.2
  855. End Sub
  856.  
  857. Private Sub Class_Terminate()
  858.    Set m_cMemDC = Nothing
  859. End Sub
  860.  
  861. Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
  862.    '
  863. End Property
  864.  
  865. Private Property Get ISubclass_MsgResponse() As EMsgResponse
  866.    ISubclass_MsgResponse = emrConsume
  867. End Property
  868.  
  869. Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  870. Dim iMenu As Long
  871. Dim iLastDownOn As Long
  872. Dim iLastOver As Long
  873. Dim lR As Long
  874. Dim lFlag As Long
  875. Dim hMenu As Long
  876. Dim iChar As Long
  877.  
  878.    Select Case iMsg
  879.    Case WM_LBUTTONDOWN
  880.       ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
  881.       ' If in range, then...
  882.       iMenu = MenuHitTest()
  883.       iLastDownOn = m_iDownOn
  884.       m_iDownOn = iMenu
  885.       If m_iDownOn <> iLastDownOn Then
  886.          ' !Repaint!
  887.          'Debug.Print "Repaint"
  888.          SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
  889.       End If
  890.       
  891.       If m_iDownOn > 0 Then
  892.          m_cTmr.Interval = 0
  893.          lR = m_cToolbarMenu.TrackPopup(m_iDownOn)
  894.          pRestoreList
  895.       End If
  896.       
  897.    Case WM_MOUSEMOVE
  898.       ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
  899.       pMouseMove
  900.       
  901.    Case WM_MEASUREITEM
  902.       ISubclass_WindowProc = MeasureItem(wParam, lParam)
  903.    
  904.    Case WM_DRAWITEM
  905.       DrawItem wParam, lParam
  906.       
  907.    Case WM_MENUCHAR
  908.       ' Check that this is my menu:
  909.       lFlag = wParam \ &H10000
  910.       If ((lFlag And MF_SYSMENU) <> MF_SYSMENU) Then
  911.          hMenu = lParam
  912.          iChar = (wParam And &HFFFF&)
  913.          ' See if this corresponds to an accelerator on the menu:
  914.          lR = ParseMenuChar(hMenu, iChar)
  915.          If lR > 0 Then
  916.             ISubclass_WindowProc = lR
  917.             Exit Function
  918.          End If
  919.       End If
  920.       ISubclass_WindowProc = CallOldWindowProc(m_hWnd, WM_MENUCHAR, wParam, lParam)
  921.    
  922.    End Select
  923.    
  924. End Function
  925. Private Function ParseMenuChar( _
  926.         ByVal hMenu As Long, _
  927.         ByVal iChar As Integer _
  928.     ) As Long
  929. Dim sChar As String
  930. Dim l As Long
  931. Dim lH() As Long
  932. Dim sItems() As String
  933.  
  934.    'Debug.Print "WM_MENUCHAR"
  935.    sChar = UCase$(Chr$(iChar))
  936.    For l = 1 To m_iRestore
  937.       If (m_hMenuRestore(l) = hMenu) Then
  938.          If (m_sAccelerator(l) = sChar) Then
  939.             ParseMenuChar = &H20000 Or m_iMenuPosition(l)
  940.             ' Debug.Print "Found Menu Char"
  941.             Exit Function
  942.          End If
  943.       End If
  944.    Next l
  945.  
  946. End Function
  947.  
  948. Private Function MeasureItem(ByVal wParam As Long, ByVal lParam As Long) As Long
  949. Dim tMIS As MEASUREITEMSTRUCT
  950. Dim lID As Long
  951.    CopyMemory tMIS, ByVal lParam, LenB(tMIS)
  952.    If tMIS.CtlType = ODT_MENU Then
  953.                   
  954.       ' because we don't get the popup menu handle
  955.       ' in the tMIS structure, we have to do an internal
  956.       ' lookup to find info about this menu item.
  957.       ' poor implementation of MEASUREITEMSTRUCT - it
  958.       ' should have a .hWndItem field like DRAWITEMSTRUCT
  959.       ' - spm
  960.       lID = InternalIDForWindowsID(tMIS.itemID)
  961.             
  962.       ' Width:
  963.       tMIS.itemWidth = 4 + 22 + m_lMenuTextSize(lID) + 4
  964.       If m_lMenuShortCutSize(lID) > 0 Then
  965.          tMIS.itemWidth = tMIS.itemWidth + 4 + m_lMenuShortCutSize(lID) + 4
  966.       End If
  967.       
  968.       ' Height:
  969.       If lID > 0 And lID <= m_iRestore Then
  970.          If (m_tMIIS(lID).fType And MFT_SEPARATOR) = MFT_SEPARATOR Then
  971.             tMIS.itemHeight = 6
  972.          Else
  973.             ' menu item height is always the same
  974.             tMIS.itemHeight = m_lMenuItemHeight + 8
  975.          End If
  976.       Else
  977.          ' problem.
  978.       End If
  979.       
  980.       CopyMemory ByVal lParam, tMIS, LenB(tMIS)
  981.       
  982.    Else
  983.       MeasureItem = CallOldWindowProc(m_hWnd, WM_MEASUREITEM, wParam, lParam)
  984.    End If
  985. End Function
  986. Private Function DrawItem(ByVal wParam As Long, ByVal lParam As Long) As Long
  987. Dim tDIS As DRAWITEMSTRUCT
  988. Dim hBr As Long
  989. Dim tR As RECT, tTR As RECT, tWR As RECT
  990. Dim lhDC As Long
  991. Dim hFntOld As Long
  992. Dim tMII As MENUITEMINFO
  993. Dim bRadioCheck As Boolean, bDisabled As Boolean, bChecked As Boolean, bHighlighted As Boolean
  994. Dim lID As Long
  995. Dim hFntS As Long, hFntSOld As Long
  996.  
  997.    CopyMemory tDIS, ByVal lParam, LenB(tDIS)
  998.    If tDIS.CtlType = ODT_MENU Then
  999.       ' Todo
  1000.       ' tDIS.hWndItem is the menu containing the item, tDIS.itemID is the wID
  1001.       
  1002.       m_cMemDC.Width = tDIS.rcItem.right - tDIS.rcItem.left + 1
  1003.       m_cMemDC.Height = tDIS.rcItem.bottom - tDIS.rcItem.top + 1
  1004.       lhDC = m_cMemDC.hdc
  1005.       hFntOld = SelectObject(lhDC, hFont)
  1006.       
  1007.       LSet tR = tDIS.rcItem
  1008.       OffsetRect tR, -tR.left, -tR.top
  1009.       
  1010.       ' Fill background:
  1011.       tTR.right = m_cMemDC.Width
  1012.       tTR.bottom = m_cMemDC.Height
  1013.       hBr = CreateSolidBrush(TranslateColor(m_oMenuBackgroundColor))
  1014.       FillRect lhDC, tTR, hBr
  1015.       DeleteObject hBr
  1016.       
  1017.       SetBkMode lhDC, TRANSPARENT
  1018.       
  1019.       ' Draw the text:
  1020.       tMII.cbSize = LenB(tMII)
  1021.       tMII.fMask = MIIM_TYPE Or MIIM_STATE Or MIIM_DATA
  1022.       GetMenuItemInfo tDIS.hwndItem, tDIS.itemID, False, tMII
  1023.       
  1024.       If (tMII.fType And MFT_SEPARATOR) = MFT_SEPARATOR Then
  1025.          ' Separator:
  1026.          LSet tWR = tR
  1027.          tWR.top = (tWR.bottom - tWR.top - 2) \ 2 + tWR.top
  1028.          tWR.bottom = tWR.top + 2
  1029.          InflateRect tWR, -8, 0
  1030.          DrawEdge lhDC, tWR, BDR_SUNKENOUTER, BF_TOP Or BF_BOTTOM
  1031.       Else
  1032.          ' Text item:
  1033.          bRadioCheck = ((tMII.fType And MFT_RADIOCHECK) = MFT_RADIOCHECK)
  1034.          bDisabled = ((tMII.fState And MFS_DISABLED) = MFS_DISABLED)
  1035.          bChecked = ((tMII.fState And MFS_CHECKED) = MFS_CHECKED)
  1036.          bHighlighted = ((tMII.fState And MFS_HILITE) = MFS_HILITE)
  1037.          If bHighlighted Then
  1038.             SetTextColor lhDC, TranslateColor(m_oActiveMenuColorOver)
  1039.          Else
  1040.             SetTextColor lhDC, TranslateColor(m_oActiveMenuColor)
  1041.          End If
  1042.          
  1043.          ' Check:
  1044.          If bChecked Then
  1045.             LSet tWR = tR
  1046.             InflateRect tWR, -4, -4
  1047.             tWR.left = tWR.left + 2
  1048.             tWR.right = tWR.left + (tWR.bottom - tWR.top + 1)
  1049.             DrawEdge lhDC, tWR, BDR_SUNKENOUTER, BF_RECT
  1050.             
  1051.             SelectObject lhDC, hFntOld
  1052.             hFntSOld = SelectObject(lhDC, hFontSymbol)
  1053.             If bRadioCheck Then
  1054.                pDrawItem lhDC, "h", tWR, bDisabled, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
  1055.             Else
  1056.                pDrawItem lhDC, "b", tWR, bDisabled, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
  1057.             End If
  1058.             SelectObject lhDC, hFntSOld
  1059.             hFntOld = SelectObject(lhDC, hFont)
  1060.             
  1061.          End If
  1062.          
  1063.          ' Draw text:
  1064.          LSet tWR = tR
  1065.          tWR.left = 20 + 4
  1066.          lID = tMII.dwItemData
  1067.          If lID > 0 And lID <= m_iRestore Then
  1068.             pDrawItem lhDC, m_sCaption(lID), tWR, bDisabled, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
  1069.             If Len(m_sShortCut(lID)) > 0 Then
  1070.                tWR.left = tWR.left + m_lMenuTextSize(lID) + 4 + 4
  1071.                pDrawItem lhDC, m_sShortCut(lID), tWR, bDisabled, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
  1072.             End If
  1073.          End If
  1074.          
  1075.          ' Highlighted:
  1076.          If bHighlighted And Not (bDisabled) Then
  1077.             LSet tWR = tR
  1078.             InflateRect tWR, -2, 0
  1079.             DrawEdge lhDC, tWR, BDR_RAISEDINNER, BF_RECT
  1080.          End If
  1081.          
  1082.       End If
  1083.       
  1084.       SelectObject lhDC, hFntOld
  1085.       
  1086.       BitBlt tDIS.hdc, tDIS.rcItem.left, tDIS.rcItem.top, tDIS.rcItem.right - tDIS.rcItem.left + 1, tDIS.rcItem.bottom - tDIS.rcItem.top + 1, lhDC, 0, 0, vbSrcCopy
  1087.       
  1088.    Else
  1089.       DrawItem = CallOldWindowProc(m_hWnd, WM_DRAWITEM, wParam, lParam)
  1090.    End If
  1091. End Function
  1092. Private Sub pDrawItem( _
  1093.       ByVal lhDC As Long, _
  1094.       ByVal sText As String, _
  1095.       ByRef tR As RECT, _
  1096.       ByVal bDisabled As Boolean, _
  1097.       ByVal dtFlags As Long _
  1098.    )
  1099. Dim tWR As RECT
  1100.    LSet tWR = tR
  1101.    If bDisabled Then
  1102.       SetTextColor lhDC, TranslateColor(vb3DHighlight)
  1103.       OffsetRect tWR, 1, 1
  1104.       DrawText lhDC, sText, -1, tWR, dtFlags
  1105.       SetTextColor lhDC, TranslateColor(vbButtonShadow)
  1106.       OffsetRect tWR, -1, -1
  1107.       DrawText lhDC, sText, -1, tWR, dtFlags
  1108.    Else
  1109.       DrawText lhDC, sText, -1, tWR, dtFlags
  1110.    End If
  1111. End Sub
  1112. Private Sub pMouseMove()
  1113. Dim iMenu As Long
  1114. Dim iLastOver As Long
  1115.    iMenu = MenuHitTest()
  1116.    iLastOver = m_iOver
  1117.    m_iOver = iMenu
  1118.    'Debug.Print "Over:", m_iOver, iLastOver
  1119.    If m_iOver <> iLastOver Then
  1120.       ' !Repaint!
  1121.       'Debug.Print "Repaint"
  1122.       SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
  1123.    End If
  1124.    If m_cTmr Is Nothing Then
  1125.       Set m_cTmr = New CTimer
  1126.    End If
  1127.    If m_iOver < 1 And m_iDownOn = 0 Then
  1128.       m_cTmr.Interval = 0
  1129.    Else
  1130.       If m_iDownOn > 0 Then
  1131.          If GetAsyncKeyState(vbLeftButton) = 0 Then
  1132.             m_iDownOn = 0
  1133.             SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
  1134.          End If
  1135.       End If
  1136.       m_cTmr.Interval = 50
  1137.    End If
  1138. End Sub
  1139.  
  1140. Private Sub m_cTmr_ThatTime()
  1141.    pMouseMove
  1142. End Sub
  1143. ' Convert Automation color to Windows color
  1144. Private Function TranslateColor(ByVal clr As OLE_COLOR, _
  1145.                         Optional hPal As Long = 0) As Long
  1146.     If OleTranslateColor(clr, hPal, TranslateColor) Then
  1147.         TranslateColor = CLR_INVALID
  1148.     End If
  1149. End Function
  1150.  
  1151.  
  1152.  
  1153.