menuitems.cls

星级酒店管理系统（附带系统自写控件源码）

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "MenuItems"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Dim colMenuItems As New Collection
Const MOUSE_UP = 1
Const MOUSE_DOWN = -1
Const MOUSE_MOVE = 0

' 添加菜单项到菜单集合
' 参数:         sCaption    菜单项标题
'               lIndex      位置
'               picIcon     图标
Public Function Add(ByVal sCaption As String, lIndex As Long, lButtonHeight As Long, picIcon As Object) As MenuItem
    Dim newMenuItem As New MenuItem
    
    On Error Resume Next
    With newMenuItem
        .Caption = sCaption
        .Index = lIndex
        .ButtonHeight = lButtonHeight
        Set .Button = picIcon
            
        If colMenuItems.Count = 0 Or lIndex = colMenuItems.Count + 1 Then
            colMenuItems.Add newMenuItem
        ElseIf lIndex = 1 Then
            colMenuItems.Add newMenuItem, , 1
        Else
            colMenuItems.Add newMenuItem, , , lIndex - 1
        End If
    End With
    
    Set Add = newMenuItem
End Function

' 删除菜单项
' 参数:       lIndex  为集合中位置
Public Sub Delete(lIndex As Long)
    On Error Resume Next
    colMenuItems.Remove lIndex
    
End Sub

Public Function Item(lIndex As Long) As MenuItem
    On Error Resume Next
    Set Item = colMenuItems.Item(lIndex)
End Function

Public Function Count() As Long
    
    On Error Resume Next
    Count = colMenuItems.Count

End Function

' 画所有菜单项（图标与标题）
' 参数:       bRecalc
'             True    强制重新计算图标位置
'             False   使用当前图标位置
Public Function Paint(lTopMenuItemDisplayed As Long, lIconStart As Long, lMenuCur As Long, lClipY As Long) As Boolean
    Dim MenuItem As MenuItem
    
    For Each MenuItem In colMenuItems
        With MenuItem
            Paint = .PaintButton(lTopMenuItemDisplayed, lIconStart, lMenuCur, lClipY)
        End With
    Next
End Function

' 鼠标事件
Public Function MouseProcess(ByVal iMousePosition, ByVal x As Long, ByVal y As Long) As Long
    Dim MenuItem As MenuItem
    Dim bResult As Boolean
    Dim lIndex As Long
    Static lLastDown As Long
    
    On Error Resume Next
    For Each MenuItem In colMenuItems
        With MenuItem
            bResult = .HitTest(iMousePosition, x, y)
            lIndex = .Index
            If bResult Then
                Select Case iMousePosition
                    Case MOUSE_UP
                        If lLastDown = lIndex Then
                            MouseProcess = lIndex
                        End If
                    Case Else
                        MouseProcess = lIndex
                End Select
                If iMousePosition = MOUSE_DOWN Then
                    lLastDown = lIndex
                End If
            End If
        End With
    Next
End Function