menus.cls

OA编程 源代码

    With picMenu
        hDestDC = .hdc
        .ScaleMode = vbPixels
        .ForeColor = vbButtonText
        lWidth = .ScaleWidth
        lStartY = (mlMenuCur) * mlButtonHeight
        lStopY = .ScaleHeight - (lMax - mlMenuPrev) * mlButtonHeight
        lBottomOfGroupY = 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, _
            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
    
    ' make sure the group is in it's correct final position
#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

' draw the icons for the currently select menu
' support subroutine for Paint
Private Sub DrawIcons()
    On Error Resume Next
    colMenus.Item(mlMenuCur).PaintItems IconStart(), mlMenuCur, ClipY(), colMenus.Count
End Sub

' support subroutine for Paint
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      ' the menu is at the top of the control
                .ButtonTop = (lIndex - 1) * mlButtonHeight
            Else                            ' the menu is at the bottom of the control
                .ButtonTop = picMenu.ScaleHeight - (lMax - lIndex + 1) * mlButtonHeight
            End If
        End With
    Next
End Sub

' determines if the mouse was clicked in a menu button
' returns the index of the menu clicked
' if no menu clicked, returns 0
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

' Process mouse events
' Note that even if we get a hit, we must process all code
' The individual objects handle their own paints depending what
' the mouse is doing.
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
    
    ' first test for a MenuButtonHit
    If iMousePosition = MOUSE_DOWN Then
        lResult = IsMenuButtonClicked(x, y)
        'if lResult is non-zero we have a hit
        ' so tell the calling procedure and return
        If lResult <> 0 Then
            lHitType = HIT_TYPE_MENU_BUTTON
            MouseProcess = lResult
        End If
    End If
    
    ' test for a MenuItemHit
    ' don't do the test if we got a MenuButtonHit
    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
    
    ' test for arrow buttons
    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
        ' the upbutton is visible, hide it so it doesn't scroll
        .HideButton TYPE_UP, mlMenuCur
    End With
    
    ' setup variables
    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
        
        ' move the screen up
#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

        ' repaint the background
#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
        ' the down button is visible, hide it so it doesn't scroll
        .HideButton TYPE_DOWN, colMenus.Count - mlMenuCur
    End With
    
    ' setup variables
    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
        
        ' move the screen up
#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

        ' repaint the background
#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
        DoEvents
    Next
    
    ' redraw the icons
    DrawIcons
    SetMenuButtonsHotSpot
End Sub

Private Function IconStart() As Long
    Dim l As Long
    Dim lIconStart As Long
    
    On Error Resume Next
    
    ' calculate the offset for our first icon
    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
    
    ' calculate the clipping area where the menu bottoms start at the bottom of picmenu
    With picMenu
        .ScaleMode = vbPixels
        ClipY = .ScaleHeight - ((colMenus.Count) - mlMenuCur) * mlButtonHeight
    End With
End Function