menus.cls

OA编程 源代码

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

' add a new Menu to the collection
' Parameters:   sCaption    Caption of the Menu
'               lIndex      Location of the Menu in Menus collection
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
        ' add the item to the collection specified by lIndex
        ' note, if there is nothing in the collection, just add it
        ' if there is nothing in the collection or we are adding it at then end, just add it
        ' elseif we are inserting in the first position, add it BEFORE
        ' else add it AFTER the previous item
        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

' delete the Menu from the collection
' Parameters:       lIndex  Index of the collection member
Public Sub Delete(lIndex As Long)
    On Error Resume Next
    colMenus.Remove lIndex
End Sub

' return the object of the Menu in the collection
' Parameters:       lIndex  Index of the collection member
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

' return the number of Menus in the collection
Public Function Count() As Long
    On Error Resume Next
    Count = colMenus.Count
End Function

' move a Menu to a new location
' Parameters:       lCurIndex   the current location
'                   lNewIndex   the new location
Public Sub MoveMenu(lCurIndex As Long, lNewIndex As Long)
    ' under construction
End Sub

' move a MenuItem to a new location
' Parameters:       lCurIndex   the current location
'                   lNewIndex   the new location
Public Sub MoveMenuItem(lCurIndex As Long, lNewIndex As Long)
    ' undex construction
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

' Procedure: Paint
' This is the main procedure that paints our control
' It handles repaints as well as well as changes of the
' current menu
' Since we can move several menus at once, the code for
' this is done here in the collection of menus rather then
' the the menu class itself.  However, the painting of the
' MenuItems is done in the MenuItem class itself.
Public Sub Paint()
    On Error Resume Next
    If mlMenuPrev = 0 Then               ' first time paint
        mlMenuPrev = mlMenuCur
    End If

    If mlMenuPrev = mlMenuCur Then
        Repaint
    ElseIf mlMenuPrev < mlMenuCur Then    ' user selected a menu after the previously selected menu
        ReselectDown
    Else                                ' user selected a menu before the previously selected menu
        ReselectUp
    End If
    
    DrawIcons
    
    SetMenuButtonsHotSpot
    
    mlMenuPrev = mlMenuCur                ' save this menu as the next previous menu
End Sub

' repaint the menu as is - no changes were made
' support subroutine for Paint
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
    
    ' setup variables
    lMax = colMenus.Count
    With picMenu
        ' if we just changed the number of menus then
        ' we need to clear the control first
        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
    
    ' first, paint the menus up to the currently select one
    For l = 1 To mlMenuCur
        With picMenu
            ' draw the button
#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
            ' print the caption
            sCaption = colMenus.Item(l).Caption
            .CurrentX = (lWidth \ 2) - (.TextWidth(sCaption) \ 2)
            .CurrentY = (l - 1) * mlButtonHeight + 2
            picMenu.Print sCaption
        End With
    Next
    
    ' now, paint the menus below the currently seleted one (from the bottom up)
    For l = lMax To mlMenuCur + 1 Step -1
        With picMenu
            ' draw the button
#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
            ' print the caption
            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

' the new current menu is further down on the menu than the previous one
' we need to move the menus up from the previous menu + 1 to the new current menu
' support subroutine for Paint
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

    ' setup variables
    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

    ' make sure the group is in it's correct final position
#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

' the new current menu is further up on the menu than the previous one
' we need to move the menus down from the current menu + 1 to the previous menu
' support subroutine for Paint
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

    ' setup variables
    bFirst = True
    lMax = colMenus.Count