vertmenu.ctl

OA编程 源代码

    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

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    Dim l As Long
    
    On Error Resume Next
    
    mbInitializing = True
    mbVBEnvironment = IsThisVB
    mMenus.ButtonHeight = BUTTON_HEIGHT             ' set button height for icons
    
    ' set property defaults
    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
    
    Me.MenusBorderStyle = mMenusBorderStyle
    
    ProcessDefaultIcon
    
    ' setup the image cache
    With picCache
        .Width = picMenu.Width
        .Height = (BUTTON_HEIGHT * 2) + 33
'        .BackColor = BACKGROUND_COLOR
        .BackColor = &H8000000C  '&H80000004 '&H959595
    End With
'    picMenu.BackColor = BACKGROUND_COLOR
    picMenu.BackColor = &H8000000C  ' &H80000004 '&H959595
    
    ' setup the control
    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
    
    ' setup the menu caption button and menu item icon cache
    SetupCache

    mbInitializing = False
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Dim lSavMenuItemCur As Long
    
    On Error Resume Next
    mbInitializing = True
    mbVBEnvironment = IsThisVB
'    picMenu.BackColor = BACKGROUND_COLOR
    picMenu.BackColor = &H8000000C '&H80000004 '&H959595
    
    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
        
        ' setup the image cache
        With picCache
            .Width = UserControl.Width
            .Height = (BUTTON_HEIGHT * 2) + 33
    
'            .BackColor = BACKGROUND_COLOR
            .BackColor = &H8000000C '&H80000004 '&H959595
        End With
    
        ' add the first menu (which already exists on the form) to the collection
        ' note that calling MenusMax only add and deletes menus other that the 1 item
        ' in the collection
        mMenus.ButtonHeight = BUTTON_HEIGHT
        MenusMax = .ReadProperty("MenusMax", m_def_MenusMax)
        
        ' setup the control arrays
        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
        ' reset mlMenuCur right away so we don't have errors!
        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
    
    ' setup the menu caption button and menu item icon cache
    SetupCache
    
    mbInitializing = False
End Sub

'Write property values to storage
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)
        
            ' image stuff here
            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             ' nothing to do
        Case Is > mlMenuItemsMax        ' add menus
            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        ' delete menus
            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
    ' reset the caption in the properties window
    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 we are calling from AsyncReadComplete event, get out of here!
    If mbAsyncReadComplete Then
        Exit Property
    End If
    
    If New_MenuItemCur > mlMenuItemsMax Then
        Beep
        MsgBox "The current item must be between 0 and 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
    
    ' total MenuItems on the control
    lMenuItemCount = mMenus.TotalMenuItems
    
    With picCache
        .ScaleMode = vbPixels
        
        ' set the height for a menu button, space for an unpainted button
        ' space for an unpainted icon and all the MenuItem icons
        .Height = BUTTON_HEIGHT * 2 + (lMenuItemCount + 1) * ICON_SIZE

        ' loop thru the menus getting each icon for each MenuItem
        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()
    ' UserControl contains the default picture
    ' set it into mpicMenuItemIcon to use as the default icon
    ' (it will be written to the property bag later)
    ' then delete UserControl.Picture
    ' note that if mpicMenuItemIcon is nothing, then we are reading from
    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

Public Sub ShowAboutBox()
Attribute ShowAboutBox.VB_UserMemId = -552
    dlgAbout.Show vbModal
    Unload dlgAbout
    Set dlgAbout = Nothing
End Sub

' we need to if we are running in VB or a browser
' VB supports this extender object while a browser doesn't
' note:  we can't read icons from the property bag using a browser - GPF's
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


'================== 控件背景色
Public Property Get MenusBackColor() As Long                  '属性出口
    On Error Resume Next
    MenusBackColor = &H8000000C 'BACKGROUND_COLOR
End Property

Public Property Let MenusBackColor(ByVal mBColor As Long)   '属性入口
    On Error Resume Next
    BACKGROUND_COLOR = mBColor
End Property

'================= 控件平面和三维的效果
Public Property Let MenusBorderStyle(ByVal mBstyle As Integer)
    On Error Resume Next
    mMenusBorderStyle = mBstyle
    UserControl.BorderStyle = mMenusBorderStyle
End Property

Public Property Get MenusBorderStyle() As Integer
    On Error Resume Next
    MenusBorderStyle = mMenusBorderStyle
End Property