home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / MenuBar_co2132961122008.psc / Classes / clsMenu.cls < prev    next >
Text File  |  2008-01-20  |  10KB  |  422 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 = "clsMenu"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = False
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. ' Private Variables
  17. Private m_IconAlignment    As Alignments
  18. Private m_Password         As Boolean
  19. Private m_ArrowDown        As clsArrow
  20. Private m_ArrowUp          As clsArrow
  21. Private m_MenuItems        As clsMenuItems
  22. Private m_Index            As Integer
  23. Private m_TopMenuItem      As Integer
  24. Private m_ButtonHeight     As Long
  25. Private m_Border           As Long
  26. Private picMenu            As PictureBox
  27. Private picCache           As PictureBox
  28. Private m_HotSpot          As Rect
  29. Private m_Icon             As StdPicture
  30. Private m_Caption          As String
  31. Private m_Tag              As String
  32. Private m_ToolTipText      As String
  33.  
  34. Public Property Let BackColor(ByVal NewBackColor As Long)
  35.  
  36.    m_ArrowUp.BackColor = NewBackColor
  37.    m_ArrowDown.BackColor = NewBackColor
  38.  
  39. End Property
  40.  
  41. Public Property Let Border(ByVal NewBorder As Long)
  42.  
  43.    m_Border = NewBorder
  44.    m_ArrowUp.Border = NewBorder
  45.    m_ArrowDown.Border = NewBorder
  46.  
  47. End Property
  48.  
  49. Public Property Get ButtonHeight() As Long
  50.  
  51.    ButtonHeight = m_ButtonHeight
  52.  
  53. End Property
  54.  
  55. Public Property Let ButtonHeight(ByVal NewButtonHeight As Long)
  56.  
  57. Dim intItem As Integer
  58.  
  59.    m_ButtonHeight = NewButtonHeight
  60.    m_ArrowUp.ButtonHeight = NewButtonHeight
  61.    m_ArrowDown.ButtonHeight = NewButtonHeight
  62.    
  63.    With m_MenuItems
  64.       For intItem = 1 To .Count
  65.          .Item(intItem).ButtonHeight = NewButtonHeight
  66.       Next 'intItem
  67.    End With
  68.  
  69. End Property
  70.  
  71. Public Property Get ButtonTop() As Long
  72.  
  73.    ButtonTop = m_HotSpot.Top
  74.  
  75. End Property
  76.  
  77. Public Property Let ButtonTop(ByVal NewButtonTop As Long)
  78.  
  79.    With m_HotSpot
  80.       .Left = 0
  81.       .Top = NewButtonTop
  82.       .Right = picMenu.ScaleWidth
  83.       .Bottom = NewButtonTop + m_ButtonHeight
  84.    End With
  85.  
  86. End Property
  87.  
  88. Public Property Get Caption() As String
  89.  
  90.    Caption = m_Caption
  91.  
  92. End Property
  93.  
  94. Public Property Let Caption(ByVal NewCaption As String)
  95.  
  96.    m_Caption = NewCaption
  97.  
  98. End Property
  99.  
  100. Public Property Set Control(ByRef NewControl As PictureBox)
  101.  
  102.    Set picMenu = NewControl
  103.    Set m_ArrowUp.Parent = NewControl
  104.    Set m_ArrowDown.Parent = NewControl
  105.  
  106. End Property
  107.  
  108. Public Property Let ForeColor(ByVal NewForeColor As Long)
  109.  
  110.    m_ArrowUp.ForeColor = NewForeColor
  111.    m_ArrowDown.ForeColor = NewForeColor
  112.  
  113. End Property
  114.  
  115. Public Property Let GradientColor(ByVal NewGradientColor As Long)
  116.  
  117.    m_ArrowUp.GradientColor = NewGradientColor
  118.    m_ArrowDown.GradientColor = NewGradientColor
  119.  
  120. End Property
  121.  
  122. Public Property Let GradientType(ByVal NewGradientType As Long)
  123.  
  124.    m_ArrowUp.GradientType = NewGradientType
  125.    m_ArrowDown.GradientType = NewGradientType
  126.  
  127. End Property
  128.  
  129. Public Property Get Icon() As StdPicture
  130.  
  131.    Set Icon = m_Icon
  132.  
  133. End Property
  134.  
  135. Public Property Set Icon(ByRef NewIcon As StdPicture)
  136.  
  137.    Set m_Icon = NewIcon
  138.  
  139. End Property
  140.  
  141. Public Property Get IconAlignment() As Alignments
  142.  
  143.    IconAlignment = m_IconAlignment
  144.  
  145. End Property
  146.  
  147. Public Property Let IconAlignment(ByRef NewIconAlignment As Alignments)
  148.  
  149.    m_IconAlignment = NewIconAlignment
  150.  
  151. End Property
  152.  
  153. Public Property Set ImageCache(ByRef NewImageCache As PictureBox)
  154.  
  155.    Set picCache = NewImageCache
  156.  
  157. End Property
  158.  
  159. Public Property Get Index() As Integer
  160.  
  161.    Index = m_Index
  162.  
  163. End Property
  164.  
  165. Public Property Let Index(ByVal NewIndex As Integer)
  166.  
  167.    m_Index = NewIndex
  168.  
  169. End Property
  170.  
  171. Public Property Get MenuItems() As clsMenuItems
  172.  
  173.    Set MenuItems = m_MenuItems
  174.  
  175. End Property
  176.  
  177. Public Property Get Password() As Boolean
  178.  
  179.    Password = m_Password
  180.  
  181. End Property
  182.  
  183. Public Property Let Password(ByVal NewPassword As Boolean)
  184.  
  185.    m_Password = NewPassword
  186.  
  187. End Property
  188.  
  189. Public Property Get Tag() As String
  190.  
  191.    Tag = m_Tag
  192.  
  193. End Property
  194.  
  195. Public Property Let Tag(ByVal NewTag As String)
  196.  
  197.    m_Tag = NewTag
  198.  
  199. End Property
  200.  
  201. Public Property Get ToolTipText() As String
  202.  
  203.    ToolTipText = m_ToolTipText
  204.  
  205. End Property
  206.  
  207. Public Property Let ToolTipText(ByVal NewToolTipText As String)
  208.  
  209.    m_ToolTipText = NewToolTipText
  210.  
  211. End Property
  212.  
  213. Public Property Get TopMenuItem() As Integer
  214.  
  215.    If m_TopMenuItem = 0 Then m_TopMenuItem = 1
  216.    
  217.    TopMenuItem = m_TopMenuItem
  218.  
  219. End Property
  220.  
  221. Public Property Let TopMenuItem(ByVal NewTopMenuItem As Integer)
  222.  
  223.    If NewTopMenuItem Then m_TopMenuItem = NewTopMenuItem
  224.  
  225. End Property
  226.  
  227. Public Function AddMenuItem(ByVal Caption As String, ByVal MenuItemlIndex As Integer, ByRef picIcon As StdPicture) As clsMenuItem
  228.  
  229.    With m_MenuItems
  230.       .Add Caption, MenuItemlIndex, m_ButtonHeight, picIcon
  231.       Set .Item(MenuItemlIndex).Parent = picMenu
  232.       Set .Item(MenuItemlIndex).Cache = picCache
  233.    End With
  234.  
  235. End Function
  236.  
  237. Public Function ClearItemHit(ByVal MousePosition As Long, ByVal X As Long, ByVal Y As Long) As Boolean
  238.  
  239. Dim intItem As Integer
  240.  
  241.    With m_MenuItems
  242.       For intItem = 1 To .Count
  243.          .Item(intItem).HitTest MousePosition, X, Y
  244.       Next 'intItem
  245.    End With
  246.  
  247. End Function
  248.  
  249. Public Function HitTest(ByVal MousePosition As Long, ByVal X As Long, ByVal Y As Long) As Boolean
  250.  
  251. Dim lngEdge As Long
  252.  
  253.    If MousePosition = MOUSE_DOWN Then
  254.       lngEdge = SUNKEN
  255.       
  256.    Else
  257.       lngEdge = RAISED
  258.    End If
  259.    
  260.    If PtInRect(m_HotSpot, X, Y) Then Call DrawBorder(lngEdge)
  261.  
  262. End Function
  263.  
  264. Public Function IsMenuSelected(ByVal X As Long, ByVal Y As Long) As Boolean
  265.  
  266.    IsMenuSelected = Not (PtInRect(m_HotSpot, X, Y) = 0)
  267.    
  268.    If Err.Number Then
  269.       IsMenuSelected = False
  270.       Err.Clear
  271.    End If
  272.  
  273. End Function
  274.  
  275. Public Function MenuItem(ByVal Index As Integer) As clsMenuItem
  276.  
  277.    Set MenuItem = m_MenuItems.Item(Index)
  278.  
  279. End Function
  280.  
  281. Public Function MenuItemCount() As Integer
  282.  
  283.    MenuItemCount = m_MenuItems.Count
  284.  
  285. End Function
  286.  
  287. Public Function MouseProcessForArrows(ByVal MousePosition As Long, ByVal X As Long, ByVal Y As Long) As Integer
  288.  
  289. Const BUTTON_DOWN         As Integer = -1
  290. Const BUTTON_UP           As Integer = 1
  291. Const SCROLL_DOWN         As Integer = -100
  292.  
  293. Static lngPrevPosition(1) As Long
  294.  
  295. Dim clsUpDownArrow        As clsArrow
  296. Dim intCount              As Integer
  297. Dim lngDirection          As Long
  298.  
  299.    For intCount = 0 To 1
  300.       If intCount Then
  301.          Set clsUpDownArrow = m_ArrowUp
  302.          
  303.       Else
  304.          Set clsUpDownArrow = m_ArrowDown
  305.       End If
  306.       
  307.       If clsUpDownArrow.HitTest(MousePosition, X, Y) Then
  308.          If MousePosition = MOUSE_UP Then
  309.             If lngPrevPosition(intCount) = BUTTON_DOWN Then
  310.                If intCount Then
  311.                   lngDirection = SCROLL_UP
  312.                   
  313.                Else
  314.                   lngDirection = SCROLL_DOWN
  315.                End If
  316.                
  317.                MouseProcessForArrows = CInt(lngDirection)
  318.             End If
  319.             
  320.             lngPrevPosition(intCount) = MousePosition
  321.             
  322.          ElseIf MousePosition = MOUSE_DOWN Then
  323.             MouseProcessForArrows = HIT_TYPE_ARROW
  324.             lngPrevPosition(intCount) = MousePosition
  325.             
  326.          ' MOUSE_CHECK or MOUSE_MOVE
  327.          Else
  328.             MouseProcessForArrows = HIT_TYPE_ARROW
  329.             
  330.             If lngPrevPosition(intCount) <> BUTTON_DOWN Then lngPrevPosition(intCount) = MousePosition
  331.          End If
  332.          
  333.       ElseIf MousePosition = MOUSE_UP Then
  334.          lngPrevPosition(intCount) = BUTTON_UP
  335.       End If
  336.    Next 'intCount
  337.    
  338.    Set clsUpDownArrow = Nothing
  339.  
  340. End Function
  341.  
  342. Public Function PaintItems(ByVal FirstIcon As Long, ByVal CurrentMenu As Integer, ByVal ClipHeight As Long, ByVal Max As Integer, ByVal ItemIconSize As Integer, ByVal ItemIconAlignment As AlignmentConstants, ByVal OnlyFullItemsShow As Boolean, ByVal OnlyFullItemsHit As Boolean, ByVal ButtonHideInSingleMenu As Boolean) As Integer
  343.  
  344.    m_MenuItems.ItemsShowed = 0
  345.    
  346.    If m_MenuItems.Paint(m_TopMenuItem, FirstIcon, CurrentMenu, ClipHeight, ItemIconSize, OnlyFullItemsShow, OnlyFullItemsHit, ButtonHideInSingleMenu) Then
  347.       m_ArrowDown.Hide
  348.       
  349.    Else
  350.       m_ArrowDown.Show ItemIconAlignment, MenusAtBottom:=Max - CurrentMenu
  351.    End If
  352.    
  353.    If m_TopMenuItem > 1 Then
  354.       m_ArrowUp.Show ItemIconAlignment, MenusAtTop:=CurrentMenu - (CurrentMenu And ButtonHideInSingleMenu)
  355.       
  356.    Else
  357.       m_ArrowUp.Hide
  358.    End If
  359.    
  360.    PaintItems = m_MenuItems.ItemsShowed
  361.  
  362. End Function
  363.  
  364. Public Sub DeleteMenuItem(ByVal MenuItemlIndex As Long)
  365.  
  366.    Call m_MenuItems.Delete(MenuItemlIndex)
  367.  
  368. End Sub
  369.  
  370. Public Sub HideButton(ByVal ButtonUp As Boolean, ByVal Offset As Long)
  371.  
  372.    If ButtonUp Then
  373.       m_ArrowUp.Hide
  374.       
  375.    Else
  376.       m_ArrowDown.Hide
  377.    End If
  378.  
  379. End Sub
  380.  
  381. Public Sub DrawBorder(ByVal Edge As Long)
  382.  
  383. Dim lngEdge As Long
  384.  
  385.    If Edge = RAISED Then
  386.       lngEdge = m_Border
  387.       
  388.    ' SUNKEN
  389.    ElseIf m_Border = BDR_RAISED Then
  390.       lngEdge = BDR_SUNKEN
  391.       
  392.    Else
  393.       lngEdge = BDR_SUNKENINNER
  394.    End If
  395.    
  396.    DrawEdge picMenu.hDC, m_HotSpot, lngEdge, BF_RECT
  397.  
  398. End Sub
  399.  
  400. Private Sub Class_Initialize()
  401.  
  402.    Set m_MenuItems = New clsMenuItems
  403.    Set m_ArrowDown = New clsArrow
  404.    Set m_ArrowUp = New clsArrow
  405.    m_ArrowUp.ArrowUp = ARROW_BUTTON_UP
  406.    m_ArrowDown.ArrowUp = ARROW_BUTTON_DOWN
  407.    m_TopMenuItem = 1
  408.  
  409. End Sub
  410.  
  411. Private Sub Class_Terminate()
  412.  
  413.    Set m_Icon = Nothing
  414.    Set m_MenuItems = Nothing
  415.    Set m_ArrowDown = Nothing
  416.    Set m_ArrowUp = Nothing
  417.    Set picCache = Nothing
  418.    Set picMenu = Nothing
  419.  
  420. End Sub
  421.  
  422.