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

Private picMenu As PictureBox
Private picCache As PictureBox
Private colMenus As New Collection
Private mlButtonHeight As Long
Private mlMenuPrev As Long
Private mlMenuCur As Long
Private mbNumberOfMenusChanged As Boolean

#If USE_WING Then
    Private Declare Function WinGBitBlt Lib "wing32.dll" (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) As Long
#Else
    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
#End If

Const SRCCOPY = &HCC0020
Const PIXELS_PER_BITBLT = 1
Const TYPE_UP = 1
Const TYPE_DOWN = -1

Public Function Add(ByVal sCaption As String, lIndex As Long, ByVal picMenu As Object) As VMenu
    Dim newMenu As New VMenu
    
    On Error Resume Next
    
    With newMenu
        .Caption = sCaption
        .Index = lIndex
        Set .Control = picMenu
        .ButtonHeight = mlButtonHeight
    End With
        If colMenus.Count = 0 Then
            colMenus.Add newMenu
        ElseIf lIndex = colMenus.Count + 1 Then
            colMenus.Add newMenu
        ElseIf lIndex = 1 Then
            colMenus.Add newMenu, , 1
        Else
            colMenus.Add newMenu, , , lIndex - 1
        End If
    
    Set Add = newMenu
End Function

Public Sub Delete(lIndex As Long)
    On Error Resume Next
    colMenus.Remove lIndex
End Sub

Public Property Get Item(lIndex As Variant) As VMenu
    On Error Resume Next
    If lIndex > 0 Then
        Set Item = colMenus(lIndex)
    End If
End Property

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

Public Sub MoveMenu(lCurIndex As Long, lNewIndex As Long)
    '
End Sub

Public Sub MoveMenuItem(lCurIndex As Long, lNewIndex As Long)
    '
End Sub

Public Property Get Caption(lIndex As Long) As String
    On Error Resume Next
    Caption = colMenus(lIndex).Caption
End Property

Public Property Let Caption(lIndex As Long, sNewValue As String)
    On Error Resume Next
    colMenus(lIndex).Caption = sNewValue
End Property

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
End Property

Public Property Set Menu(oNewValue As PictureBox)
    On Error Resume Next
    Set picMenu = oNewValue
End Property

Public Property Set Cache(oNewValue As PictureBox)
    On Error Resume Next
    Set picCache = oNewValue
End Property

Public Property Let MenuCur(lNewValue As Long)
    On Error Resume Next
    mlMenuCur = lNewValue
End Property

Public Sub Paint()
    On Error Resume Next
    If mlMenuPrev = 0 Then
        mlMenuPrev = mlMenuCur
    End If

    If mlMenuPrev = mlMenuCur Then
        Repaint
    ElseIf mlMenuPrev < mlMenuCur Then
        ReselectDown
    Else
        ReselectUp
    End If
    
    DrawIcons
    
    SetMenuButtonsHotSpot
    
    mlMenuPrev = mlMenuCur
End Sub

Private Sub Repaint()
    Dim l As Long
    Dim lMax As Long
    Dim lResult As Long
    Dim hDestDC As Long
    Dim hSrcDC As Long
    Dim sCaption As String
    Dim lWidth As Long
    Dim lHeight As Long
    On Error Resume Next
    
    lMax = colMenus.Count
    With picMenu
        If mbNumberOfMenusChanged Then
            .Cls
            mbNumberOfMenusChanged = False
        End If
        hDestDC = .hdc
        .ScaleMode = vbPixels
        .ForeColor = vbButtonText
        lWidth = CLng(.ScaleWidth)
        lHeight = CLng(.ScaleHeight)
    End With
    hSrcDC = picCache.hdc
    
    If lMax = 0 Or hDestDC = 0 Or hSrcDC = 0 Then
        Exit Sub
    End If
    
    For l = 1 To mlMenuCur
        With picMenu
#If USE_WING Then
            lResult = WinGBitBlt(hDestDC, 0, _
                (l - 1) * mlButtonHeight, _
                lWidth, _
                mlButtonHeight, _
                hSrcDC, 0, 0)
#Else
            lResult = BitBlt(hDestDC, 0, _
                (l - 1) * mlButtonHeight, _
                lWidth, _
                mlButtonHeight, _
                hSrcDC, 0, 0, SRCCOPY)
#End If
            sCaption = colMenus.Item(l).Caption
            .CurrentX = (lWidth \ 2) - (.TextWidth(sCaption) \ 2)
            .CurrentY = (l - 1) * mlButtonHeight + 2
            picMenu.Print sCaption
        End With
    Next
    
    For l = lMax To mlMenuCur + 1 Step -1
        With picMenu
#If USE_WING Then
            lResult = WinGBitBlt(hDestDC, 0, _
                lHeight - (lMax - l + 1) * mlButtonHeight, _
                lWidth, _
                mlButtonHeight, _
                hSrcDC, 0, 0)
#Else
            lResult = BitBlt(hDestDC, 0, _
                lHeight - (lMax - l + 1) * mlButtonHeight, _
                lWidth, _
                mlButtonHeight, _
                hSrcDC, 0, 0, SRCCOPY)
#End If
            sCaption = colMenus.Item(l).Caption
            .CurrentX = (lWidth \ 2) - (.TextWidth(sCaption) \ 2)
            .CurrentY = lHeight - (lMax - l + 1) * mlButtonHeight + 2
            picMenu.Print sCaption
        End With
    Next
    
End Sub

Private Sub ReselectDown()
    Dim lStartY As Long
    Dim lStopY As Long
    Dim lTopOfGroupY As Long
    Dim lPixelCount As Long
    Dim lResult As Long
    Dim lMax As Long
    Dim hDestDC As Long
    Dim hSrcDC As Long
    Dim lWidth As Long
    Dim bFirst As Boolean
    
    On Error Resume Next

    bFirst = True
    lMax = colMenus.Count
    With picMenu
        hDestDC = .hdc
        .ScaleMode = vbPixels
        .ForeColor = vbButtonText
        lWidth = .ScaleWidth
        lStopY = mlMenuPrev * mlButtonHeight
        lStartY = .ScaleHeight - (lMax - mlMenuCur) * mlButtonHeight
        lTopOfGroupY = .ScaleHeight - (lMax - mlMenuPrev) * mlButtonHeight
    End With
    hSrcDC = picCache.hdc
    
    If lMax = 0 Or hDestDC = 0 Or hSrcDC = 0 Then
        Exit Sub
    End If
    
    Do
#If USE_WING Then
        lResult = WinGBitBlt(hDestDC, 0, _
            lStopY, _
            lWidth, _
            lStartY - lStopY - lPixelCount - PIXELS_PER_BITBLT - ((Not (bFirst)) * PIXELS_PER_BITBLT), _
            hDestDC, 0, lStopY + PIXELS_PER_BITBLT)
#Else
        lResult = BitBlt(hDestDC, 0, _
            lStopY, _
            lWidth, _
            lStartY - lStopY - lPixelCount - PIXELS_PER_BITBLT - ((Not (bFirst)) * PIXELS_PER_BITBLT), _
            hDestDC, 0, lStopY + PIXELS_PER_BITBLT, SRCCOPY)
#End If
        If bFirst Then
#If USE_WING Then
            lResult = WinGBitBlt(hDestDC, 0, _
                lStartY - PIXELS_PER_BITBLT, _
                lWidth, _
                PIXELS_PER_BITBLT, _
                hSrcDC, 0, mlButtonHeight + 3)
#Else
            lResult = BitBlt(hDestDC, 0, _
                lStartY - PIXELS_PER_BITBLT, _
                lWidth, _
                PIXELS_PER_BITBLT, _
                hSrcDC, 0, mlButtonHeight + 3, SRCCOPY)
            bFirst = False
#End If
        End If
        
        lPixelCount = lPixelCount + PIXELS_PER_BITBLT
    
    Loop Until lTopOfGroupY - ((lPixelCount + 1) * PIXELS_PER_BITBLT) <= lStopY

#If USE_WING Then
    lResult = WinGBitBlt(hDestDC, 0, _
        lStopY, _
        lWidth, _
        lStartY - lStopY - 1 - lPixelCount - (Not (bFirst) * PIXELS_PER_BITBLT), _
        hDestDC, 0, lTopOfGroupY - lPixelCount)
#Else
    lResult = BitBlt(hDestDC, 0, _
        lStopY, _
        lWidth, _
        lStartY - lStopY - 1 - lPixelCount - (Not (bFirst) * PIXELS_PER_BITBLT), _
        hDestDC, 0, lTopOfGroupY - lPixelCount, SRCCOPY)
#End If
End Sub

Private Sub ReselectUp()
    Dim lStartY As Long
    Dim lStopY As Long
    Dim lBottomOfGroupY As Long
    Dim lPixelCount As Long
    Dim lResult As Long
    Dim lMax As Long
    Dim hDestDC As Long
    Dim hSrcDC As Long
    Dim lWidth As Long
    Dim bFirst As Boolean
    
    On Error Resume Next
    bFirst = True
    lMax = colMenus.Count
    With picMenu
        hDestDC = .hdc
        .ScaleMode = vbPixels
        .ForeColor = vbButtonText
        lWidth = .ScaleWidth
        lStartY = (mlMenuCur) * mlButtonHeight
        lStopY = .ScaleHeight - (lMax - mlMenuPrev) * mlButtonHeight
        lBottomOfGroupY = mlMenuPrev * mlButtonHeight