menuitem.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 = "MenuItem"
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 msCaption As String      ' 菜单标题
Private mlIndex As Long          ' 菜单图标索引
Private picButton As Picture     ' 图标图片
Private msCaptionX As Long
Private msCaptionY As Long
Private mlButtonHeight As Long
Private mbButtonDownOnMe As Boolean
Private msPictureURL As String
Private msKey As String
Private msTag As String

Private Type BUTTON_STRUCT
    RECT     As RECT
    State    As Long
    OnScreen As Boolean
End Type
Private mButtonStruct As BUTTON_STRUCT

Private mHitStruct As RECT
Private m3DStruct As RECT

#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
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hMF As Long) As Long
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function SaveDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function RestoreDC Lib "gdi32" (ByVal hdc As Long, ByVal SavedDC As Long) As Long

Const SRCCOPY = &HCC0020

Const ICON_SIZE = 32
Const MOUSE_UP = 1
Const MOUSE_DOWN = -1
Const MOUSE_MOVE = 0
Const RAISED = 1
Const SUNKEN = -1
Const NONE = 0
Const HITTEXT_EXTRA_PIXELS = 4
Const CLIPPING_NO = True
Const CLIPPING_YES = False

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
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 Button() As Object
    On Error Resume Next
    Set Button = picButton
End Property

Public Property Set Button(ByVal vNewValue As Object)
    On Error Resume Next
    Set picButton = vNewValue
End Property

Public Property Get Left() As Long
    On Error Resume Next
    Left = mButtonStruct.RECT.Left
End Property

Public Property Let Left(ByVal lNewValue As Long)
    On Error Resume Next
    With mButtonStruct.RECT
        .Left = lNewValue
        .Right = lNewValue + ICON_SIZE
    End With
End Property

Public Property Get Top() As Long
    On Error Resume Next
    Top = mButtonStruct.RECT.Top
End Property

Public Property Let Top(ByVal lNewValue As Long)
    On Error Resume Next
    With mButtonStruct.RECT
        .Top = lNewValue
        .Bottom = lNewValue + ICON_SIZE
    End With
End Property

Public Property Get Right() As Long
    On Error Resume Next
    Right = mButtonStruct.RECT.Right
End Property

Public Property Get Bottom() As Long
    On Error Resume Next
    Bottom = mButtonStruct.RECT.Bottom
End Property

Public Property Get State() As Long
    On Error Resume Next
    State = mButtonStruct.State
End Property

Public Property Let State(ByVal lNewValue As Long)
    On Error Resume Next
    mButtonStruct.State = lNewValue
End Property

Public Property Get CaptionX() As Long
    On Error Resume Next
    CaptionX = msCaptionX
End Property

Public Property Let CaptionX(ByVal lNewValue As Long)
    On Error Resume Next
    msCaptionX = lNewValue
End Property

Public Property Get CaptionY() As Long
    On Error Resume Next
    CaptionY = msCaptionY
End Property

Public Property Let CaptionY(ByVal lNewValue As Long)
    On Error Resume Next
    msCaptionY = lNewValue
End Property

' 画32*32图标
Public Function PaintButton(lTopMenuItemDisplayed, lIconStart As Long, lMenuCur As Long, lClipY As Long) As Boolean
    
    Dim lCenter As Long
    Dim lLeft As Long
    Dim lTop As Long
    Dim lRight As Long
    Dim lBottom As Long
    Dim lResult As Long
    Dim lHeight As Long
    Dim bClipping As Boolean
    Dim lPositionFromTop As Long
    Dim RgnRect As RECT
    Dim hRgn As Long
    Dim lRetCod As Long
    Dim hSavedDC As Long
    
    On Error Resume Next
    
    If mlIndex < lTopMenuItemDisplayed Then
        mButtonStruct.OnScreen = False
        PaintButton = CLIPPING_NO
        Exit Function
    End If
    
    ' 放置图片
    lPositionFromTop = mlIndex - lTopMenuItemDisplayed + 1
    Top = (lPositionFromTop * 2 * ICON_SIZE) - ICON_SIZE + ((lPositionFromTop + 1 = 1) * 4) + (lMenuCur - 1) * mlButtonHeight
    With picMenu
        .ScaleMode = vbPixels
        lCenter = .ScaleWidth \ 2
        Left = lCenter - (ICON_SIZE \ 2)
    End With
    
    With mButtonStruct
        lLeft = .RECT.Left
        lTop = .RECT.Top
        lRight = .RECT.Right
        lBottom = .RECT.Bottom
    
        If lTop > lClipY Then
            .OnScreen = False
            PaintButton = CLIPPING_YES
            Exit Function
        End If
        If lBottom > lClipY Then
            bClipping = True
            lBottom = lClipY
        End If
        .OnScreen = True
    End With
    ' 菜单标题定位
    CaptionX = lCenter - (CLng(picMenu.TextWidth(Caption())) \ 2)
    CaptionY = lTop + ICON_SIZE + 4

    With mHitStruct
        .Left = lLeft - HITTEXT_EXTRA_PIXELS - 2
        .Top = lTop - HITTEXT_EXTRA_PIXELS - 2
        .Right = lRight + HITTEXT_EXTRA_PIXELS + 2
        .Bottom = lBottom + picMenu.TextHeight(Caption()) + 5
        If bClipping Then
            .Bottom = lBottom
        End If
    End With
        
    ' 计算机3D结构
    With m3DStruct
        .Left = lLeft - 2
        .Top = lTop - 2
        .Right = lRight + 2
        If Not bClipping Then
            .Bottom = lBottom + 2
        Else
            .Bottom = lBottom
        End If
    End With
    
    With mButtonStruct.RECT
        If Not bClipping Then
            lHeight = ICON_SIZE
        Else
            lHeight = lBottom - lTop
        End If
#If USE_WING Then
        lResult = WinGBitBlt(picMenu.hdc, .Left, _
            .Top, _
            ICON_SIZE, lHeight, _
            picCache.hdc, 0, mlButtonHeight * 2 + (lIconStart + lPositionFromTop) * ICON_SIZE)
#Else
        lResult = BitBlt(picMenu.hdc, .Left, _
            .Top, _
            ICON_SIZE, lHeight, _
            picCache.hdc, 0, mlButtonHeight * 2 + (lIconStart + lPositionFromTop) * ICON_SIZE, SRCCOPY)
#End If
    End With
    
    If Not bClipping Then
        With picMenu
            .CurrentX = msCaptionX
            .CurrentY = msCaptionY
            .ForeColor = vbWhite
            If .CurrentY + .TextHeight(msCaption) < lClipY Then
                picMenu.Print msCaption
                PaintButton = CLIPPING_NO
            Else
                With picMenu
                    RgnRect.Left = 0
                    RgnRect.Top = msCaptionY
                    RgnRect.Right = .Width
                    RgnRect.Bottom = lClipY
                    hSavedDC = SaveDC(.hdc)
                    hRgn = CreateRectRgnIndirect(RgnRect)
                    lRetCod = SelectClipRgn(.hdc, hRgn)
                    picMenu.Print msCaption
                    hRgn = DeleteObject(hRgn)
                    lRetCod = RestoreDC(.hdc, hSavedDC)
                    
                    PaintButton = CLIPPING_YES
                End With
            End If
        End With
    Else
        PaintButton = CLIPPING_YES
    End If
End Function

Public Property Set Parent(ByVal picNewValue As Control)
    On Error Resume Next
    Set picMenu = picNewValue
End Property

Public Function HitTest(ByVal iMousePosition As Integer, ByVal x As Long, ByVal y As Long) As Boolean
    
    If Not mButtonStruct.OnScreen Then
        Exit Function
    End If
    
    If PtInRect(mHitStruct, x, y) Then
        HitTest = True
        
        Select Case iMousePosition
            Case MOUSE_UP
                Select Case mButtonStruct.State
                    Case SUNKEN, NONE
                        DrawBorder RAISED
                    Case Else
                End Select
                mbButtonDownOnMe = False
            Case MOUSE_DOWN
                Select Case mButtonStruct.State
                    Case SUNKEN
                    Case Else
                        DrawBorder SUNKEN
                        mbButtonDownOnMe = True
                End Select
            Case MOUSE_MOVE
                Select Case mButtonStruct.State
                    Case RAISED
                    Case NONE
                        If Not mbButtonDownOnMe Then
                            DrawBorder RAISED
                        Else
                            DrawBorder SUNKEN
                        End If
                    Case SUNKEN
                End Select
        End Select
    Else
        HitTest = False
        
        If iMousePosition <> MOUSE_MOVE Then
            mbButtonDownOnMe = False
        End If
        If mButtonStruct.State <> NONE Then
            DrawBorder NONE
        End If
    End If
End Function

Public Sub DrawBorder(iDirection As Integer)
    On Error Resume Next
    picMenu.ScaleMode = vbPixels
       
    If Not mButtonStruct.OnScreen Then
        Exit Sub
    End If
    
    State = iDirection
    
    If m3DStruct.Bottom - m3DStruct.Top = ICON_SIZE + 4 Then
        Select Case iDirection
            Case RAISED
                DrawEdge picMenu.hdc, m3DStruct, BDR_RAISEDOUTER, BF_RECT
            Case SUNKEN
                DrawEdge picMenu.hdc, m3DStruct, BDR_SUNKENINNER, BF_RECT
            Case NONE
                With m3DStruct
                    picMenu.Line (.Left, .Top)-(.Right - 1, .Bottom - 1), BACKGROUND_COLOR, B
                End With
        End Select
    Else
        Select Case iDirection
            Case RAISED
                DrawEdge picMenu.hdc, m3DStruct, BDR_RAISEDOUTER, BF_LEFT Or BF_TOP Or BF_RIGHT
            Case SUNKEN
                DrawEdge picMenu.hdc, m3DStruct, BDR_SUNKENINNER, BF_LEFT Or BF_TOP Or BF_RIGHT
            Case NONE
                With m3DStruct
                    picMenu.Line (.Left, .Top)-(.Right - 1, .Top), BACKGROUND_COLOR
                    picMenu.Line (.Left, .Top)-(.Left, .Bottom), BACKGROUND_COLOR
                    picMenu.Line (.Right - 1, .Top)-(.Right - 1, .Bottom), BACKGROUND_COLOR
                End With
        End Select
    End If
End Sub

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

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

Public Property Get PictureURL() As String
    On Error Resume Next
    PictureURL = msPictureURL
End Property

Public Property Let PictureURL(ByVal sNewValue As String)
    On Error Resume Next
    msPictureURL = PictureURL
End Property

Public Property Get Key() As String
    On Error Resume Next
    Key = msKey
End Property

Public Property Let Key(ByVal sNewValue As String)
    On Error Resume Next
    msKey = sNewValue
End Property

Public Property Get Tag() As String
    On Error Resume Next
    Tag = msTag
End Property

Public Property Let Tag(ByVal sNewValue As String)
    On Error Resume Next
    msTag = sNewValue
End Property