vertmenu.ctl

OA编程 源代码

VERSION 5.00
Begin VB.UserControl VerticalMenu 
   Appearance      =   0  'Flat
   AutoRedraw      =   -1  'True
   BackColor       =   &H8000000C&
   BackStyle       =   0  'Transparent
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   4785
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2985
   Picture         =   "VertMenu.ctx":0000
   PropertyPages   =   "VertMenu.ctx":0CCA
   ScaleHeight     =   319
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   199
   Begin VB.PictureBox picMenu 
      Appearance      =   0  'Flat
      BackColor       =   &H8000000C&
      BorderStyle     =   0  'None
      ClipControls    =   0   'False
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000008&
      Height          =   780
      Left            =   720
      ScaleHeight     =   780
      ScaleWidth      =   870
      TabIndex        =   1
      Top             =   2640
      Width           =   870
   End
   Begin VB.PictureBox picCache 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ClipControls    =   0   'False
      ForeColor       =   &H80000008&
      Height          =   540
      Left            =   600
      ScaleHeight     =   36
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   43
      TabIndex        =   0
      Top             =   1200
      Visible         =   0   'False
      Width           =   645
   End
   Begin VB.Image imgDown 
      Height          =   240
      Left            =   1800
      Picture         =   "VertMenu.ctx":0CF7
      Top             =   2490
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image imgUp 
      Height          =   240
      Left            =   1035
      Picture         =   "VertMenu.ctx":1239
      Top             =   180
      Visible         =   0   'False
      Width           =   240
   End
End
Attribute VB_Name = "VerticalMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Option Explicit

Dim mMenus As Menus

'Default Property Values:
Const m_def_WhatsThisHelpID = 0
Const m_def_ToolTipText = ""
Const m_def_MousePointer = 0
Const m_def_Enabled = 0
Const m_def_DrawWidth = 0
Const m_def_DrawStyle = 0
Const m_def_DrawMode = 0
Const m_def_CurrentY = 0
Const m_def_CurrentX = 0
Const m_def_BorderStyle = 0 '1
Const m_def_BackStyle = 0
Const m_def_Appearance = 0
Const m_def_AutoRedraw = 0
Const m_def_ClipControls = 0
Const m_def_ScaleWidth = 0
Const m_def_ScaleTop = 0
Const m_def_ScaleMode = 3
Const m_def_ScaleLeft = 0
Const m_def_ScaleHeight = 0
Const m_def_MenusMax = 1
Const m_def_MenuCur = 1
Const m_def_MenuStartup = 1
Const m_def_MenuCaption = "Menu"
Const m_def_MenuItemCaption = "Item"
Const m_def_MenuItemsMax = 1
Const m_def_MenuItemCur = 1

'Property Variables:
Private m_WhatsThisHelpID As Long
Private m_ToolTipText As String
Private m_MousePointer As Integer
Private m_Enabled As Boolean
Private m_DrawWidth As Integer
Private m_DrawStyle As Integer
Private m_DrawMode As Integer
Private m_CurrentY As Single
Private m_CurrentX As Single
Private m_BorderStyle As Integer
Private m_BackStyle As Integer
Private m_ActiveControl As Control
Private m_Appearance As Integer
Private m_AutoRedraw As Boolean
Private m_ClipControls As Boolean
Private m_ScaleWidth As Single
Private m_ScaleTop As Single
Private m_ScaleMode As Integer
Private m_ScaleLeft As Single
Private m_ScaleHeight As Single

Private mlMenusMax As Long
Private mlMenuCur As Long
Private mlMenuStartup As Long
Private msMenuCaption As String
Private msMenuItemCaption As String
Private mpicMenuItemIcon As Picture
Private mlMenuItemsMax As Long
Private mlMenuItemCur As Long
Private mbInitializing As Boolean
Private mbAsyncReadComplete As Boolean
Private mbVBEnvironment As Boolean
Private mMenusBorderStyle As Integer             '控件的平面和三维效果

' Constants
Const HIT_TYPE_MENU_BUTTON = 1
Const HIT_TYPE_MENUITEM = 2
Const HIT_TYPE_UP_ARROW = 3
Const HIT_TYPE_DOWN_ARROW = 4
Const BUTTON_HEIGHT = 18
Const MOUSE_UP = 1
Const MOUSE_DOWN = -1
Const MOUSE_MOVE = 0
Const MOUSE_IN_CAPTION = -2
Const ICON_SIZE = 32

'Event Declarations:
Event Show()
Event Resize()
Event Hide()
Event Click()
Event DblClick()
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Event Paint()
Event MenuItemClick(MenuNumber As Long, MenuItem As Long)


Private Sub picCache_Resize()
    DrawCacheMenuButton
End Sub



' if picMenu considers a second mousedown event as a dblclick, the
' MouseDown event does not file so we need to do it instead
Private Sub picMenu_DblClick()
    Dim POINTAPI As POINTAPI
    Dim lResCod As Long
    
    On Error Resume Next
    lResCod = GetCursorPos(POINTAPI)
    lResCod = ScreenToClient(picMenu.hWnd, POINTAPI)
    picMenu_MouseDown vbLeftButton, 0, CSng(POINTAPI.x), CSng(POINTAPI.y)
End Sub

Private Sub picMenu_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim lIndex As Long
    Dim lHitType As Long    ' return variable
    
    On Error Resume Next

    If Button = vbLeftButton Then
        With mMenus
            ' currently we only care about MenuButton hits
            ' all others are already processed
            lIndex = .MouseProcess(MOUSE_DOWN, CLng(x), CLng(y), lHitType)
            If lHitType = HIT_TYPE_MENU_BUTTON And lIndex > 0 Then
                MenuCur = lIndex
            End If
        End With
    End If
    Me.Refresh
    picMenu.Refresh
End Sub

Private Sub picMenu_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    On Error Resume Next
    ' we don't care about the HitType (an optional parameter)
    mMenus.MouseProcess MOUSE_MOVE, CLng(x), CLng(y)
    Me.MousePointer = 0
End Sub

Private Sub picMenu_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim lMenuItem As Long
    Dim lHitType As Long
    
    On Error Resume Next
    If Button = vbLeftButton Then
        lMenuItem = mMenus.MouseProcess(MOUSE_UP, CLng(x), CLng(y), lHitType)
        If lHitType = HIT_TYPE_MENUITEM And lMenuItem > 0 Then
            picMenu_MouseMove Button, Shift, x, y
            RaiseEvent MenuItemClick(mlMenuCur, lMenuItem)
            picMenu_MouseMove 0, 0, 0, 0
        End If
    End If
    Me.MousePointer = 0
End Sub

Private Sub picMenu_Paint()
    On Error Resume Next
    ' using the control with the internet explorer generates a paint
    ' event each time an icon is loaded.  Therefore, don't do the paint
    ' event unless picMenu is visible
    If picMenu.Visible Then
        mMenus.Paint
    End If
End Sub

Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)
    Dim lSavMenuCur As Long
    Dim lSavMenuItemCur As Long
    On Error Resume Next
    mbAsyncReadComplete = True
    With AsyncProp
        lSavMenuCur = mlMenuCur
        lSavMenuItemCur = mlMenuItemCur
        mlMenuCur = Val(Left$(.PropertyName, 1))
        mlMenuItemCur = Val(Mid$(.PropertyName, 2))
        Set MenuItemIcon = AsyncProp.Value
        mlMenuCur = lSavMenuCur
        mlMenuItemCur = lSavMenuItemCur
    End With
    mbAsyncReadComplete = False
End Sub

Private Sub UserControl_Paint()
    On Error Resume Next
    If Not mbInitializing Then
        picMenu_Paint
    End If
    
End Sub

Private Sub UserControl_Initialize()
    On Error Resume Next
    BACKGROUND_COLOR = &H8000000C '&H80000004 ' &H959595
    mMenusBorderStyle = 1 '0
    
    Set mMenus = New Menus
    Set mMenus.Menu = picMenu
    Set mMenus.Cache = picCache
End Sub

Private Sub UserControl_Resize()
    On Error Resume Next
    UserControl.ScaleMode = vbPixels
    With picMenu
        .ScaleMode = vbPixels
        .Left = 0
        .Top = 0
        .Width = UserControl.ScaleWidth
        .Height = UserControl.ScaleHeight

    End With
    
    With picCache
        .ScaleMode = vbPixels
        .Width = picMenu.Width
        .Height = (BUTTON_HEIGHT * 2) + 33
    End With
    Refresh
End Sub

Private Sub UserControl_Terminate()
    On Error Resume Next
    Set mMenus = Nothing
End Sub

Public Property Get MenusMax() As Long
    On Error Resume Next
    MenusMax = mlMenusMax
End Property

Public Property Let MenusMax(ByVal New_MenusMax As Long)
    Dim l As Long
    Dim lSavMenuCur As Long
    Dim hWnd As Long
    
    On Error Resume Next
    If New_MenusMax < 0 Or New_MenusMax > 6 Then
        Beep
        MsgBox "MenusMax must be between 0 and 6", vbOKOnly
        Exit Property
    End If
    
    UserControl.ScaleMode = vbPixels
    
    Select Case New_MenusMax
        Case mlMenusMax             ' nothing to do
        Case Is > mlMenusMax        ' add menus
            lSavMenuCur = mlMenuCur
            For mlMenuCur = mlMenusMax + 1 To New_MenusMax
                With mMenus
                    .Add "", mlMenuCur, picMenu
                    MenuCaption = m_def_MenuCaption & CStr(mlMenuCur)
                
                    ' set the up/down bitmaps
                    Set .Item(mlMenuCur).UpBitmap = imgUp.Picture
                    Set .Item(mlMenuCur).DownBitmap = imgDown.Picture
                    Set .Item(mlMenuCur).ImageCache = picCache
                    
                    ' add MenuItems to the menu
                    .Item(mlMenuCur).AddMenuItem m_def_MenuItemCaption, 1, mpicMenuItemIcon
                End With
            Next
            mlMenuCur = lSavMenuCur
        Case Is < mlMenusMax        ' delete menus
            For l = mlMenusMax To New_MenusMax + 1 Step -1
                With mMenus
                    .Delete l
                    If New_MenusMax < mlMenuCur Then
                        MenuCur = New_MenusMax
                    End If
                End With
            Next
    End Select
    
    mlMenusMax = New_MenusMax
    mMenus.NumberOfMenusChanged = True
    SetupCache
    UserControl_Paint
    PropertyChanged "MenusMax"
End Property

Public Property Get MenuCur() As Long
    MenuCur = mlMenuCur
End Property

Public Property Let MenuCur(ByVal New_MenuCur As Long)
    On Error Resume Next
    
    ' if we are calling from AsyncReadComplete event, get out of here!
    If mbAsyncReadComplete Then
        Exit Property
    End If
    
    mlMenuCur = New_MenuCur
    mlMenuItemCur = 1           ' reset the menuitem
    With mMenus
        .MenuCur = mlMenuCur
        mlMenuItemsMax = .Item(mlMenuCur).MenuItemCount
        MenuCaption = .Item(mlMenuCur).Caption
    End With
    PropertyChanged "MenuCur"
End Property

Public Property Get MenuStartup() As Long
    On Error Resume Next
    MenuStartup = mlMenuStartup
End Property

Public Property Let MenuStartup(ByVal New_MenuStartup As Long)
    On Error Resume Next
    mlMenuStartup = New_MenuStartup
    PropertyChanged "MenuStartup"
End Property

Public Property Get MenuCaption() As String
    On Error Resume Next
    MenuCaption = msMenuCaption
End Property

Public Property Let MenuCaption(ByVal New_MenuCaption As String)
    On Error Resume Next
    msMenuCaption = New_MenuCaption
    mMenus.Item(mlMenuCur).Caption = New_MenuCaption
    UserControl_Paint
    PropertyChanged "MenuCaption"
End Property

Public Property Get MenuItemCaption() As String
    On Error Resume Next
    msMenuItemCaption = mMenus.Item(mlMenuCur).MenuItemItem(mlMenuItemCur).Caption
    MenuItemCaption = msMenuItemCaption
End Property

Public Property Let MenuItemCaption(ByVal New_MenuItemCaption As String)
    On Error Resume Next
    With mMenus.Item(mlMenuCur)
        .MenuItemItem(mlMenuItemCur).Caption = New_MenuItemCaption
        msMenuItemCaption = New_MenuItemCaption
    End With
    If Not mbInitializing Then
        picMenu.Cls
        UserControl_Paint
    End If
    PropertyChanged "MenuItemCaption"
End Property

Public Property Get MenuItemIcon() As Picture
    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