menus.cls

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

    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, _
            lStartY + lPixelCount + PIXELS_PER_BITBLT + ((Not (bFirst)) * PIXELS_PER_BITBLT), _
            lWidth, _
            lStopY - lStartY - lPixelCount - PIXELS_PER_BITBLT - ((Not (bFirst)) * PIXELS_PER_BITBLT), _
            hDestDC, 0, lStartY + lPixelCount + ((Not (bFirst)) * PIXELS_PER_BITBLT))
#Else
        lResult = BitBlt(hDestDC, 0, _
            lStartY + lPixelCount + PIXELS_PER_BITBLT + ((Not (bFirst)) * PIXELS_PER_BITBLT), _
            lWidth, _
            lStopY - lStartY - lPixelCount - PIXELS_PER_BITBLT - ((Not (bFirst)) * PIXELS_PER_BITBLT), _
            hDestDC, 0, lStartY + lPixelCount + ((Not (bFirst)) * PIXELS_PER_BITBLT), SRCCOPY)
#End If
        
        If bFirst Then
#If USE_WING Then
            lResult = WinGBitBlt(hDestDC, 0, _
                lStartY + (lPixelCount * PIXELS_PER_BITBLT), _
                lWidth, _
                PIXELS_PER_BITBLT, _
                hSrcDC, 0, mlButtonHeight + 3)
#Else
            lResult = BitBlt(hDestDC, 0, _
                lStartY + (lPixelCount * PIXELS_PER_BITBLT), _
                lWidth, _
                PIXELS_PER_BITBLT, _
                hSrcDC, 0, mlButtonHeight + 3, SRCCOPY)
#End If
            bFirst = False
        End If
        
        lPixelCount = lPixelCount + PIXELS_PER_BITBLT
    Loop Until lBottomOfGroupY + lPixelCount >= lStopY
    
#If USE_WING Then
    lResult = WinGBitBlt(hDestDC, 0, _
        lStopY - (mlMenuPrev - mlMenuCur) * mlButtonHeight - PIXELS_PER_BITBLT, _
        lWidth, _
        (mlMenuPrev - mlMenuCur) * mlButtonHeight + PIXELS_PER_BITBLT, _
        hDestDC, 0, lStartY + lPixelCount - PIXELS_PER_BITBLT)
#Else
    lResult = BitBlt(hDestDC, 0, _
        lStopY - (mlMenuPrev - mlMenuCur) * mlButtonHeight - PIXELS_PER_BITBLT, _
        lWidth, _
        (mlMenuPrev - mlMenuCur) * mlButtonHeight + PIXELS_PER_BITBLT, _
        hDestDC, 0, lStartY + lPixelCount - PIXELS_PER_BITBLT, SRCCOPY)
#End If
End Sub

Private Sub DrawIcons()
    On Error Resume Next
    colMenus.Item(mlMenuCur).PaintItems IconStart(), mlMenuCur, ClipY(), colMenus.Count
End Sub

Private Sub SetMenuButtonsHotSpot()
    Dim lIndex As Long
    Dim lMax As Long
    Dim VMenu As VMenu
    
    On Error Resume Next
    lMax = colMenus.Count
    For Each VMenu In colMenus
        With VMenu
            lIndex = .Index
            If lIndex <= mlMenuCur Then
                .ButtonTop = (lIndex - 1) * mlButtonHeight
            Else
                .ButtonTop = picMenu.ScaleHeight - (lMax - lIndex + 1) * mlButtonHeight
            End If
        End With
    Next
End Sub

Public Function IsMenuButtonClicked(ByVal ptX As Long, ByVal ptY As Long) As Long
    Dim VMenu As VMenu
    
    On Error Resume Next
    For Each VMenu In colMenus
        With VMenu
            If .IsMenuSelected(ptX, ptY) Then
                IsMenuButtonClicked = .Index
                Exit Function
            End If
        End With
    Next
End Function

Public Property Let NumberOfMenusChanged(ByVal bNewValue As Boolean)
    On Error Resume Next
    mbNumberOfMenusChanged = bNewValue
End Property

Public Property Get TotalMenuItems() As Long
    Dim VMenu As VMenu
    Dim lTotal As Long
    
    On Error Resume Next
    For Each VMenu In colMenus
        lTotal = lTotal + VMenu.MenuItemCount
    Next
    TotalMenuItems = lTotal
End Property

Public Function MouseProcess(ByVal iMousePosition As Integer, ByVal x As Long, ByVal y As Long, Optional lHitType As Long) As Long
    Dim lResult As Long
    Dim MenuItems As MenuItems
    Const HIT_TYPE_MENU_BUTTON = 1
    Const HIT_TYPE_MENUITEM = 2
    Const HIT_TYPE_UP_ARROW = 3
    Const HIT_TYPE_DOWN_ARROW = 4
    Const SCROLL_UP = 100
    Const SCROLL_DOWN = -100
    Const MOUSE_UP = 1
    Const MOUSE_DOWN = -1
    Const MOUSE_MOVE = 0
    
    If iMousePosition = MOUSE_DOWN Then
        lResult = IsMenuButtonClicked(x, y)
        If lResult <> 0 Then
            lHitType = HIT_TYPE_MENU_BUTTON
            MouseProcess = lResult
        End If
    End If
    
    If lResult = 0 Then
        Set MenuItems = colMenus.Item(mlMenuCur).MenuItems()
        lResult = MenuItems.MouseProcess(iMousePosition, x, y)
        If iMousePosition = MOUSE_UP And lResult > 0 Then
            lHitType = HIT_TYPE_MENUITEM
            MouseProcess = lResult
        End If
    End If
    
    lResult = colMenus.Item(mlMenuCur).MouseProcessForArrows(iMousePosition, x, y)
    If lResult <> 0 Then
        Select Case lResult
            Case SCROLL_UP
                ScrollUp
                lHitType = HIT_TYPE_UP_ARROW
            Case SCROLL_DOWN
                ScrollDown
                lHitType = HIT_TYPE_DOWN_ARROW
        End Select
    End If
End Function

Private Sub ScrollUp()
    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 lPixel As Long
    Const PIXELS_TO_SCROLL = 64
    Const PIXELS_PER_BITBLT_S = 2
    
    On Error Resume Next
    With colMenus.Item(mlMenuCur)
        .TopMenuItem = .TopMenuItem - 1
        .HideButton TYPE_UP, mlMenuCur
    End With
    
    lMax = colMenus.Count
    With picMenu
        hDestDC = .hdc
        .ScaleMode = vbPixels
        .ForeColor = vbButtonText
        lWidth = .ScaleWidth
        lStartY = mlMenuCur * mlButtonHeight
        lStopY = .ScaleHeight - (lMax - mlMenuCur) * mlButtonHeight
    End With
    hSrcDC = picCache.hdc
    
    If lMax = 0 Or hDestDC = 0 Or hSrcDC = 0 Then
        Exit Sub
    End If
    
    For lPixel = 1 To PIXELS_TO_SCROLL \ PIXELS_PER_BITBLT_S
        
#If USE_WING Then
        lResult = WinGBitBlt(hDestDC, 0, _
            lStartY + PIXELS_PER_BITBLT_S, _
            lWidth, _
            lStopY - lStartY - 2, _
            hDestDC, 0, lStartY)
#Else
        lResult = BitBlt(hDestDC, 0, _
            lStartY + PIXELS_PER_BITBLT_S, _
            lWidth, _
            lStopY - lStartY - 2, _
            hDestDC, 0, lStartY, SRCCOPY)
#End If

#If USE_WING Then
        lResult = WinGBitBlt(hDestDC, 0, _
            lStartY, _
            lWidth, _
            PIXELS_PER_BITBLT_S, _
            hSrcDC, 0, mlButtonHeight + 3)
#Else
        lResult = BitBlt(hDestDC, 0, _
            lStartY, _
            lWidth, _
            PIXELS_PER_BITBLT_S, _
            hSrcDC, 0, mlButtonHeight + 3, SRCCOPY)
#End If

        lPixelCount = lPixelCount + PIXELS_PER_BITBLT_S
    Next
    
    DrawIcons
    SetMenuButtonsHotSpot
End Sub

Private Sub ScrollDown()
    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 lPixel As Long
    Const PIXELS_TO_SCROLL = 64
    Const PIXELS_PER_BITBLT_S = 2
    
    On Error Resume Next
    With colMenus.Item(mlMenuCur)
        .TopMenuItem = .TopMenuItem + 1
        .HideButton TYPE_DOWN, colMenus.Count - mlMenuCur
    End With
    
    lMax = colMenus.Count
    With picMenu
        hDestDC = .hdc
        .ScaleMode = vbPixels
        .ForeColor = vbButtonText
        lWidth = .ScaleWidth
        lStopY = mlMenuCur * mlButtonHeight
        lStartY = .ScaleHeight - (lMax - mlMenuCur) * mlButtonHeight
    End With
    hSrcDC = picCache.hdc
    
    If lMax = 0 Or hDestDC = 0 Or hSrcDC = 0 Then
        Exit Sub
    End If
        
    For lPixel = 1 To PIXELS_TO_SCROLL \ PIXELS_PER_BITBLT_S
        
#If USE_WING Then
        lResult = WinGBitBlt(hDestDC, 0, _
            lStopY, _
            lWidth, _
            lStartY - lStopY, _
            hDestDC, 0, lStopY + PIXELS_PER_BITBLT_S)
#Else
        lResult = BitBlt(hDestDC, 0, _
            lStopY, _
            lWidth, _
            lStartY - lStopY, _
            hDestDC, 0, lStopY + PIXELS_PER_BITBLT_S, SRCCOPY)
#End If

#If USE_WING Then
        lResult = WinGBitBlt(hDestDC, 0, _
            lStartY - PIXELS_PER_BITBLT_S, _
            lWidth, _
            PIXELS_PER_BITBLT_S, _
            hSrcDC, 0, mlButtonHeight + 3)
#Else
        lResult = BitBlt(hDestDC, 0, _
            lStartY - PIXELS_PER_BITBLT_S, _
            lWidth, _
            PIXELS_PER_BITBLT_S, _
            hSrcDC, 0, mlButtonHeight + 3, SRCCOPY)
#End If

        lPixelCount = lPixelCount + PIXELS_PER_BITBLT_S
    Next
    
    DrawIcons
    SetMenuButtonsHotSpot
End Sub

Private Function IconStart() As Long
    Dim l As Long
    Dim lIconStart As Long
    
    On Error Resume Next
    
    For l = 1 To mlMenuCur - 1
        lIconStart = lIconStart + colMenus.Item(l).MenuItemCount
    Next
    IconStart = lIconStart + colMenus.Item(mlMenuCur).TopMenuItem - 1
End Function

Private Function ClipY() As Long
    On Error Resume Next
    With picMenu
        .ScaleMode = vbPixels
        ClipY = .ScaleHeight - ((colMenus.Count) - mlMenuCur) * mlButtonHeight
    End With
End Function