vertmenu.ctl

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

    On Error Resume Next
    Set MenuItemIcon = mMenus.Item(mlMenuCur).MenuItemItem(mlMenuItemCur).Button
End Property

Public Property Set MenuItemIcon(ByVal New_MenuItemIcon As Picture)
    On Error Resume Next
    Set mMenus.Item(mlMenuCur).MenuItemItem(mlMenuItemCur).Button = New_MenuItemIcon
    If Not mbInitializing Then
        SetupCache
        UserControl_Paint
    End If
    PropertyChanged "MenuItemIcon"
End Property

Public Property Get MenuItemPictureURL() As String
    On Error Resume Next
    MenuItemPictureURL = mMenus.Item(mlMenuCur).MenuItemItem(mlMenuItemCur).PictureURL
End Property

Public Property Let MenuItemPictureURL(ByVal New_MenuItemPictureURL As String)
    On Error Resume Next
    mMenus.Item(mlMenuCur).MenuItemItem(mlMenuItemCur).PictureURL = New_MenuItemPictureURL
    UserControl.AsyncRead New_MenuItemPictureURL, vbAsyncTypePicture, CStr(mlMenuCur) & CStr(mlMenuItemCur)
    If Err.Number <> 0 Then
    '    Set MenuItemIcon = mpicMenuItemIcon
        Err.Clear
    End If
    PropertyChanged "MenuItemPictureURL"
End Property

Public Property Get MenuItemKey() As String
    On Error Resume Next
    MenuItemKey = mMenus.Item(mlMenuCur).MenuItemItem(mlMenuItemCur).Key
End Property

Public Property Let MenuItemKey(ByVal New_MenuItemKey As String)
    On Error Resume Next
    mMenus.Item(mlMenuCur).MenuItemItem(mlMenuItemCur).Key = New_MenuItemKey
    PropertyChanged "MenuItemKey"
End Property

Public Property Get MenuItemTag() As String
    On Error Resume Next
    MenuItemTag = mMenus.Item(mlMenuCur).MenuItemItem(mlMenuItemCur).Tag
End Property

Public Property Let MenuItemTag(ByVal New_MenuItemTag As String)
    On Error Resume Next
    mMenus.Item(mlMenuCur).MenuItemItem(mlMenuItemCur).Tag = New_MenuItemTag
    PropertyChanged "MenuItemTag"
End Property

'初始化用户控件
Private Sub UserControl_InitProperties()
    Dim l As Long
    
    On Error Resume Next
    
    mbInitializing = True
    mbVBEnvironment = IsThisVB
    
    mMenus.ButtonHeight = BUTTON_HEIGHT

    m_Enabled = m_def_Enabled
    m_Appearance = m_def_Appearance
    m_ScaleWidth = m_def_ScaleWidth
    m_ScaleTop = m_def_ScaleTop
    m_ScaleMode = m_def_ScaleMode
    m_ScaleLeft = m_def_ScaleLeft
    m_ScaleHeight = m_def_ScaleHeight
    m_ToolTipText = m_def_ToolTipText
    m_WhatsThisHelpID = m_def_WhatsThisHelpID
    msMenuCaption = m_def_MenuCaption
    msMenuItemCaption = m_def_MenuItemCaption
    mlMenuItemCur = m_def_MenuItemCur
    mlMenuItemsMax = m_def_MenuItemsMax
    
    ProcessDefaultIcon
    
    With picCache
        .Width = picMenu.Width
        .Height = (BUTTON_HEIGHT * 2) + 33
        .BackColor = BACKGROUND_COLOR
    End With
    picMenu.BackColor = BACKGROUND_COLOR
    
    MenusMax = m_def_MenusMax
    MenuCur = m_def_MenuStartup
    MenuStartup = m_def_MenuStartup
    m_WhatsThisHelpID = m_def_WhatsThisHelpID
    m_ToolTipText = m_def_ToolTipText
    m_MousePointer = m_def_MousePointer
    m_Enabled = m_def_Enabled
    m_AutoRedraw = m_def_AutoRedraw
    m_ClipControls = m_def_ClipControls
    
    SetupCache

    mbInitializing = False
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Dim lSavMenuItemCur As Long
    
    On Error Resume Next
    mbInitializing = True
    mbVBEnvironment = IsThisVB
    picMenu.BackColor = BACKGROUND_COLOR
    
    With PropBag
        m_Enabled = .ReadProperty("Enabled", m_def_Enabled)
        m_ToolTipText = .ReadProperty("ToolTipText", m_def_ToolTipText)
        m_WhatsThisHelpID = .ReadProperty("WhatsThisHelpID", m_def_WhatsThisHelpID)
        mlMenuItemCur = m_def_MenuItemCur
        mlMenuItemsMax = m_def_MenuItemsMax
    
        Set mpicMenuItemIcon = .ReadProperty("MenuItemIcon0", Nothing)
        ProcessDefaultIcon
        
        With picCache
            .Width = UserControl.Width
            .Height = (BUTTON_HEIGHT * 2) + 33
            .BackColor = BACKGROUND_COLOR
        End With
    
        mMenus.ButtonHeight = BUTTON_HEIGHT
        MenusMax = .ReadProperty("MenusMax", m_def_MenusMax)
        
        For mlMenuCur = 1 To mlMenusMax
            MenuCur = mlMenuCur
            msMenuCaption = .ReadProperty("MenuCaption" & CStr(mlMenuCur), m_def_MenuCaption)
            MenuCaption = msMenuCaption
            
            MenuItemsMax = .ReadProperty("MenuItemsMax" & CStr(mlMenuCur), m_def_MenuItemsMax)
            
            lSavMenuItemCur = mlMenuItemCur
            For mlMenuItemCur = 1 To mMenus.Item(mlMenuCur).MenuItemCount
                If mbVBEnvironment Then
                    Set MenuItemIcon = .ReadProperty("MenuItemIcon" & CStr(mlMenuCur) & CStr(mlMenuItemCur), mpicMenuItemIcon)
                Else
                    MenuItemPictureURL = .ReadProperty("MenuItemPictureURL" & CStr(mlMenuCur) & CStr(mlMenuItemCur), "")
                End If
                MenuItemCaption = .ReadProperty("MenuItemCaption" & CStr(mlMenuCur) & CStr(mlMenuItemCur), m_def_MenuItemCaption)
                MenuItemKey = .ReadProperty("MenuItemKey" & CStr(mlMenuCur) & CStr(mlMenuItemCur), "")
                MenuItemTag = .ReadProperty("MenuItemTag" & CStr(mlMenuCur) & CStr(mlMenuItemCur), "")
            Next
            mlMenuItemCur = lSavMenuItemCur
        Next
        mlMenuCur = .ReadProperty("MenuCur", m_def_MenuCur)
        
        MenuItemCur = m_def_MenuItemCur
        mlMenuStartup = .ReadProperty("MenuStartup", m_def_MenuStartup)
        MenuStartup = mlMenuStartup
        MenuCur = mlMenuStartup
        m_WhatsThisHelpID = .ReadProperty("WhatsThisHelpID", m_def_WhatsThisHelpID)
        m_ToolTipText = .ReadProperty("ToolTipText", m_def_ToolTipText)
        m_MousePointer = .ReadProperty("MousePointer", m_def_MousePointer)
        m_Enabled = .ReadProperty("Enabled", m_def_Enabled)
        m_AutoRedraw = .ReadProperty("AutoRedraw", m_def_AutoRedraw)
        m_ClipControls = .ReadProperty("ClipControls", m_def_ClipControls)
    End With
    
    SetupCache
    
    mbInitializing = False
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Dim lSavMenuCur As Long
    Dim lSavMenuItemCur As Long
    
    On Error Resume Next
    
    With PropBag
        Call .WriteProperty("Enabled", m_Enabled, m_def_Enabled)
        Call .WriteProperty("ToolTipText", m_ToolTipText, m_def_ToolTipText)
        Call .WriteProperty("WhatsThisHelpID", m_WhatsThisHelpID, m_def_WhatsThisHelpID)
        Call .WriteProperty("MenusMax", mlMenusMax, m_def_MenusMax)
        Call .WriteProperty("MenuCur", mlMenuCur, m_def_MenuCur)
        Call .WriteProperty("MenuStartup", mlMenuStartup, m_def_MenuStartup)
        
        lSavMenuCur = mlMenuCur
        For mlMenuCur = 1 To mlMenusMax
            Call .WriteProperty("MenuCaption" & CStr(mlMenuCur), mMenus.Item(mlMenuCur).Caption, m_def_MenuCaption)
            Call .WriteProperty("MenuItemsMax" & CStr(mlMenuCur), mMenus.Item(mlMenuCur).MenuItemCount, m_def_MenuItemsMax)
            lSavMenuItemCur = mlMenuItemCur
            For mlMenuItemCur = 1 To mMenus.Item(mlMenuCur).MenuItemCount
                If mbVBEnvironment Then
                    Call .WriteProperty("MenuItemIcon" & CStr(mlMenuCur) & CStr(mlMenuItemCur), MenuItemIcon, Nothing)
                Else
                    Call .WriteProperty("MenuItemPictureURL" & CStr(mlMenuCur) & CStr(mlMenuItemCur), MenuItemPictureURL, "")
                End If
                Call .WriteProperty("MenuItemCaption" & CStr(mlMenuCur) & CStr(mlMenuItemCur), MenuItemCaption, m_def_MenuItemCaption)
                Call .WriteProperty("MenuItemKey" & CStr(mlMenuCur) & CStr(mlMenuItemCur), MenuItemKey, "")
                Call .WriteProperty("MenuItemTag" & CStr(mlMenuCur) & CStr(mlMenuItemCur), MenuItemTag, "")
            Next
            mlMenuItemCur = lSavMenuItemCur
        Next
        mlMenuCur = lSavMenuCur
        Call .WriteProperty("MenuItemIcon0", mpicMenuItemIcon, mpicMenuItemIcon)
        Call .WriteProperty("WhatsThisHelpID", m_WhatsThisHelpID, m_def_WhatsThisHelpID)
        Call .WriteProperty("ToolTipText", m_ToolTipText, m_def_ToolTipText)
        Call .WriteProperty("MousePointer", m_MousePointer, m_def_MousePointer)
        Call .WriteProperty("Enabled", m_Enabled, m_def_Enabled)
        Call .WriteProperty("AutoRedraw", m_AutoRedraw, m_def_AutoRedraw)
        Call .WriteProperty("ClipControls", m_ClipControls, m_def_ClipControls)
    End With
End Sub

Public Property Get MenuItemsMax() As Long
    On Error Resume Next
    MenuItemsMax = mlMenuItemsMax
End Property

Public Property Let MenuItemsMax(ByVal New_MenuItemsMax As Long)
    Dim l As Long
    Dim lSavMenuItemCur As Long
    
    On Error Resume Next
    If New_MenuItemsMax < 0 Or New_MenuItemsMax > 10 Then
        Beep
        MsgBox "MenuItemsMax must be between 0 and 10", vbOKOnly
        Exit Property
    End If
    
    lSavMenuItemCur = mlMenuItemCur
    Select Case New_MenuItemsMax
        Case mlMenuItemsMax
        Case Is > mlMenuItemsMax
            With mMenus.Item(mlMenuCur)
                For mlMenuItemCur = mlMenuItemsMax + 1 To New_MenuItemsMax
                    .AddMenuItem m_def_MenuItemCaption, mlMenuItemCur, mpicMenuItemIcon
                    MenuItemCaption = m_def_MenuItemCaption & CStr(mlMenuItemCur)
                Next
                mlMenuItemCur = lSavMenuItemCur
            End With
        Case Is < mlMenuItemsMax
            With mMenus.Item(mlMenuCur)
                For mlMenuItemCur = mlMenuItemsMax To New_MenuItemsMax + 1 Step -1
                    .DeleteMenuItem mlMenuItemCur
                Next
                mlMenuItemCur = lSavMenuItemCur
                If New_MenuItemsMax < mlMenuItemCur Then
                    mlMenuItemCur = New_MenuItemsMax
                End If
            End With
    End Select
    mlMenuItemsMax = New_MenuItemsMax
    SetupCache
    UserControl_Paint
    PropertyChanged "MenuItemsMax"
End Property

Public Property Get MenuItemCur() As Long
    On Error Resume Next
    MenuItemCur = mlMenuItemCur
End Property

Public Property Let MenuItemCur(ByVal New_MenuItemCur As Long)
    On Error Resume Next
    
    If mbAsyncReadComplete Then
        Exit Property
    End If
    
    If New_MenuItemCur > mlMenuItemsMax Then
        Beep
        MsgBox "当前项目必须在 0 到 MenuItemsMax", vbOKOnly
        Exit Property
    End If
    mlMenuItemCur = New_MenuItemCur
    PropertyChanged "MenuItemCur"
End Property

Public Sub SetupCache()
    Dim lMenuItemCount As Long
    Dim lMIndex As Long
    Dim lMMax As Long
    Dim lMIIndex As Long
    Dim lMIMax As Long
    Dim lIconIndex As Long
    Const I_OFFSET = BUTTON_HEIGHT * 2 + ICON_SIZE

    On Error Resume Next
    
    picCache.Cls
    DrawCacheMenuButton
    
    lMenuItemCount = mMenus.TotalMenuItems
    
    With picCache
        .ScaleMode = vbPixels
        
        .Height = BUTTON_HEIGHT * 2 + (lMenuItemCount + 1) * ICON_SIZE

        lMMax = mMenus.Count
        lIconIndex = 0
        For lMIndex = 1 To lMMax
            lMIMax = mMenus.Item(lMIndex).MenuItemCount
            For lMIIndex = 1 To lMIMax
                lIconIndex = lIconIndex + 1
                picCache.PaintPicture mMenus.Item(lMIndex).MenuItemItem(lMIIndex).Button, _
                    0, I_OFFSET + (lIconIndex - 1) * ICON_SIZE, ICON_SIZE, ICON_SIZE, 0, 0
            Next
        Next
    End With
End Sub

Private Sub ProcessDefaultIcon()
    On Error Resume Next
    If mpicMenuItemIcon Is Nothing Then
        Set mpicMenuItemIcon = UserControl.Picture
    End If
    UserControl.Picture = LoadPicture()
End Sub

Private Sub DrawCacheMenuButton()
    Dim RECT As RECT
    
    RECT.Left = 0
    RECT.Top = 0
    RECT.Right = picCache.ScaleWidth
    RECT.Bottom = BUTTON_HEIGHT
    DrawEdge picCache.hdc, RECT, BDR_RAISED, BF_RECT Or BF_MIDDLE
End Sub

Public Property Get WhatsThisHelpID() As Long
Attribute WhatsThisHelpID.VB_Description = "Returns/sets an associated context number for an object."
    WhatsThisHelpID = m_WhatsThisHelpID
End Property

Public Property Let WhatsThisHelpID(ByVal New_WhatsThisHelpID As Long)
    m_WhatsThisHelpID = New_WhatsThisHelpID
    PropertyChanged "WhatsThisHelpID"
End Property

Public Property Get ToolTipText() As String
Attribute ToolTipText.VB_Description = "Returns/sets the text displayed when the mouse is paused over the control."
    ToolTipText = m_ToolTipText
End Property

Public Property Let ToolTipText(ByVal New_ToolTipText As String)
    m_ToolTipText = New_ToolTipText
    PropertyChanged "ToolTipText"
End Property

Public Sub Refresh()
Attribute Refresh.VB_Description = "Forces a complete repaint of a object."
    UserControl_Paint
End Sub

Public Property Get MousePointer() As Integer
Attribute MousePointer.VB_Description = "Returns/sets the type of mouse pointer displayed when over part of an object."
    MousePointer = m_MousePointer
End Property

Public Property Let MousePointer(ByVal New_MousePointer As Integer)
    m_MousePointer = New_MousePointer
    PropertyChanged "MousePointer"
End Property

Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
    Enabled = m_Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    m_Enabled = New_Enabled
    PropertyChanged "Enabled"
End Property

Public Property Get ClipControls() As Boolean
Attribute ClipControls.VB_Description = "Determines whether graphics methods in Paint events repaint an entire object or newly exposed areas."
    ClipControls = m_ClipControls
End Property

Public Property Let ClipControls(ByVal New_ClipControls As Boolean)
    m_ClipControls = New_ClipControls
    PropertyChanged "ClipControls"
End Property

Private Function IsThisVB() As Boolean
    Dim obj As Object

    On Error Resume Next
    Set UserControl.Extender.Parent = obj
    IsThisVB = (Err.Number = 0)
    Set obj = Nothing
    Err.Clear
End Function