menu.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 = "VMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private msCaption As String
Private mlIndex As Long
Private picMenu As PictureBox
Private picCache As PictureBox
Private mlButtonHeight As Long
Private mMenuItems As MenuItems
Private mpicUp As Arrow
Private mpicDown As Arrow
Private mHotSpot As RECT
Private mlTopMenuItemDisplayed As Long

Const TYPE_UP = 1
Const TYPE_DOWN = -1
Const BTN_UP = 1
Const BTN_DOWN = -1
Const MOUSE_UP = 1
Const MOUSE_DOWN = -1
Const MOUSE_MOVE = 0
Const SCROLL_DOWN = -100
Const SCROLL_UP = 100

Public Property Get Caption() As String
    On Error Resume Next
    Caption = msCaption
End Property

Public Property Let Caption(ByVal sNewValue As String)
    On Error Resume Next
    msCaption = sNewValue
    If mlIndex > 0 Then
    End If
End Property

Public Property Get Index() As Long
    On Error Resume Next
    Index = mlIndex
End Property

Public Property Let Index(ByVal lNewValue As Long)
    On Error Resume Next
    mlIndex = lNewValue
End Property

Public Property Get Control() As Object
    On Error Resume Next
    Set Control = picMenu
End Property

Public Property Set Control(pic As Object)
    On Error Resume Next
    Set picMenu = pic
    
    Set mpicUp.Parent = pic
    Set mpicDown.Parent = pic
End Property

Public Function AddMenuItem(sCaption As String, lMenuItemlIndex As Long, picIcon As Object) As MenuItems
    On Error Resume Next
    With mMenuItems
        .Add sCaption, lMenuItemlIndex, mlButtonHeight, picIcon
        Set .Item(lMenuItemlIndex).Parent = picMenu
        Set .Item(lMenuItemlIndex).Cache = picCache
    End With
End Function

Public Sub DeleteMenuItem(lMenuItemlIndex As Long)
    On Error Resume Next
    mMenuItems.Delete lMenuItemlIndex
End Sub

Public Function MenuItemCount() As Long
    On Error Resume Next
    MenuItemCount = mMenuItems.Count
End Function

Public Function MenuItemItem(lMenuItemlIndex As Long) As MenuItem
    On Error Resume Next
    Set MenuItemItem = mMenuItems.Item(lMenuItemlIndex)
End Function

Public Function MouseProcessForArrows(ByVal iMousePosition, ByVal x As Long, ByVal y As Long) As Long
    Dim bResult As Boolean
    Dim pic As Arrow
    Dim i As Integer
    Static lLastPosition(1) As Long
        
    On Error Resume Next
    For i = 0 To 1
        If i = 0 Then
            Set pic = mpicDown
        Else
            Set pic = mpicUp
        End If

        bResult = pic.HitTest(iMousePosition, x, y)
        If bResult Then
            Select Case iMousePosition
                Case MOUSE_UP
                    If lLastPosition(i) = BTN_DOWN Then
                        If i = 0 Then
                            MouseProcessForArrows = SCROLL_DOWN
                        Else
                            MouseProcessForArrows = SCROLL_UP
                        End If
                    End If
                    lLastPosition(i) = iMousePosition
                Case MOUSE_DOWN
                    lLastPosition(i) = iMousePosition
                Case MOUSE_MOVE
                    If lLastPosition(i) <> BTN_DOWN Then
                        lLastPosition(i) = iMousePosition
                    End If
            End Select
        Else
            If iMousePosition = MOUSE_UP Then
                lLastPosition(i) = BTN_UP
            End If
        End If
    Next
    Set pic = Nothing
End Function

Public Property Get ButtonHeight() As Long
    On Error Resume Next
    ButtonHeight = mlButtonHeight
End Property

Public Property Let ButtonHeight(ByVal lNewValue As Long)
    On Error Resume Next
    mlButtonHeight = lNewValue
    mpicUp.ButtonHeight = lNewValue
    mpicDown.ButtonHeight = lNewValue
End Property

Private Sub Class_Initialize()
    On Error Resume Next
    Set mMenuItems = New MenuItems
    
    Set mpicUp = New Arrow
    mpicUp.ArrowType = TYPE_UP
    
    Set mpicDown = New Arrow
    mpicDown.ArrowType = TYPE_DOWN
    
    mlTopMenuItemDisplayed = 1
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    Set mpicDown = Nothing
    Set mpicUp = Nothing
    Set picMenu = Nothing
End Sub

Public Property Get UpBitmap() As Object
    On Error Resume Next
    Set UpBitmap = mpicUp.Bitmap
End Property

Public Property Set UpBitmap(ByVal oNewValue As Object)
    On Error Resume Next
    Set mpicUp.Bitmap = oNewValue
End Property

Public Property Get DownBitmap() As Object
    On Error Resume Next
    Set DownBitmap = mpicDown.Bitmap
End Property

Public Property Set DownBitmap(ByVal oNewValue As Object)
    On Error Resume Next
    Set mpicDown.Bitmap = oNewValue
End Property

Public Property Set ImageCache(ByVal ctlNewValue As Object)
    On Error Resume Next
    Set picCache = ctlNewValue
End Property

Public Function IsMenuSelected(ByVal ptX As Long, ByVal ptY As Long) As Boolean
    On Error Resume Next
    IsMenuSelected = Not (PtInRect(mHotSpot, ptX, ptY) = 0)
    If Err.Number <> 0 Then
        IsMenuSelected = False
        Err.Clear
    End If
End Function

Public Property Get ButtonTop() As Long
    ButtonTop = mHotSpot.Top
End Property

Public Property Let ButtonTop(ByVal lNewValue As Long)
    With picMenu
        .ScaleMode = vbPixels
        mHotSpot.Left = 0
        mHotSpot.Top = lNewValue
        mHotSpot.Right = .ScaleWidth
        mHotSpot.Bottom = lNewValue + mlButtonHeight
    End With
End Property

Public Function PaintItems(lIconStart As Long, lMenuCur As Long, lClipY As Long, lMax As Long) As Boolean
    Dim i As Integer
    
    On Error Resume Next
    If Not mMenuItems.Paint(mlTopMenuItemDisplayed, lIconStart, lMenuCur, lClipY) Then
        mpicDown.Show BTN_UP, MenusAtBottom:=lMax - lMenuCur + 1, TotalMenus:=lMax
    Else
        mpicDown.Hide
    End If
    If mlTopMenuItemDisplayed > 1 Then
       mpicUp.Show BTN_UP, MenusAtTop:=lMenuCur, TotalMenus:=lMax
    Else
        mpicUp.Hide
    End If
End Function

Public Property Get MenuItems() As MenuItems
    On Error Resume Next
    Set MenuItems = mMenuItems
End Property

Public Sub HideButton(iThisButton As Integer, lOffset As Long)
    On Error Resume Next
    If iThisButton = TYPE_UP Then
        mpicUp.Hide
    Else
        mpicDown.Hide
    End If
End Sub

Public Property Get TopMenuItem() As Long
    If mlTopMenuItemDisplayed = 0 Then
        mlTopMenuItemDisplayed = 1
    End If
    TopMenuItem = mlTopMenuItemDisplayed
End Property

Public Property Let TopMenuItem(ByVal lNewValue As Long)
    If lNewValue <> 0 Then
        mlTopMenuItemDisplayed = lNewValue
    End If
End Property