VBA 使用表格驱动来建立独立应用程序的菜单（自定义菜单）

    <style type="text/css">

'
' Description:  This module builds the custom CommandBars specified by the
'               entries in the wksCommandBars worksheet table.
'
' Authors:      Stephen Bullen, www.oaltd.co.uk
'               Rob Bovey, www.appspro.com
'
' Chapter Change Overview
' Ch#   Comment
' --------------------------------------------------------------
' 06    Initial version
' 07    Added Window menu to support multiple-document interface
' 08    Replaced the item-by-item method of v7 with a new table-driven
'       commandbar builder. The wksCommandBars worksheet contains the table.
' 12    Added error handling to all non-trivial procedures.
'
Option Explicit
Option Private Module

' **************************************************************************** ' Module Constant Declarations Follow ' **************************************************************************** Private Const msMODULE As String = "MCommandBars"

Private Const mlMAX_TABLE_ROWS As Long = 10000 ' The maximum number of rows the routine will use (just a safety precaution). Private Const mlPROPERTY_NOT_SET As Long = -9999 ' Indicates that a Long data type property was not specified (0 is a valid setting for many CommandBarControl Long properties). Private Const mlCUSTOM_CONTROL As Long = 1 ' Indicates that the control will be a custom control, not a built-in control.

'''''' wksCommandBars worksheet table range name constants. '''''''''''''''''' ' Marks the first cell in the CommandBar definition table. Private Const msRNG_TABLE_START As String = "TableStart"

' These properties apply only to CommandBars. Private Const msCOL_POSITION As String = "Position" Private Const msCOL_IS_MENU_BAR As String = "IsMenubar" Private Const msCOL_VISIBLE As String = "Visible" Private Const msCOL_PROTECTION As String = "Protection"

' These properties apply to both CommandBars and CommandBarControls. Private Const msCOL_WIDTH As String = "Width" Private Const msCOL_IS_TEMPORARY As String = "IsTemporary" Private Const msCOL_IS_ENABLED As String = "IsEnabled"

' These properties apply only to CommandBarControls. Private Const msCOL_ONACTION As String = "OnAction" Private Const msCOL_CONTROL_ID As String = "ControlID" Private Const msCOL_CONTROL_TYPE As String = "ControlType" Private Const msCOL_CONTROL_STYLE As String = "ControlStyle" Private Const msCOL_FACE_ID As String = "FaceID" Private Const msCOL_BEGIN_GROUP As String = "BeginGroup" Private Const msCOL_BEFORE As String = "Before" Private Const msCOL_TOOLTIP As String = "Tooltip" Private Const msCOL_SHORTCUT_TEXT As String = "ShortcutText" Private Const msCOL_TAG As String = "Tag" Private Const msCOL_PARAMETER As String = "Parameter" Private Const msCOL_STATE As String = "State" Private Const msCOL_LIST_RANGE As String = "ListRange"

' **************************************************************************** ' Module Type Declaractions Follow ' **************************************************************************** ' This type structure holds the data for a single command bar. The elements ' are listed in the order in which they appear in the wksCommandBars table. Private Type COMMANDBAR_PROPERTIES sBarName As String ' The name of the CommandBar. lPosition As Long ' The location of the CommandBar. bIsMenuBar As Boolean ' Whether or not the CommandBar will be a menu bar. bVisible As Boolean ' Whether or not the CommandBar will be made immediately visible. lWidth As Long ' You can specify a width for msoBarFloating command bars. lProtection As Long ' Controls what kinds of changes the user will be allowed to make to the CommandBar. bIsTemporary As Boolean ' Whether the CommandBar will persist between sessions. bIsEnabled As Boolean ' Whether the CommandBar will be enabled upon creation. Disabled CommandBars are not visible to the user. End Type

' This type structure holds the data for a single command bar control. ' The elements are listed in the order in which they appear in the wksCommandBars table. Private Type CONTROL_PROPERTIES sControlName As String ' The name of the control. lWidth As Long ' The width of the control. bIsTemporary As Boolean ' Whether the control will persist between sessions. bIsEnabled As Boolean ' Whether the control will be enabled upon creation. sOnAction As String ' The macro assigned to the control. lControlID As Long ' Used to specify a built-in control. lControlType As Long ' What kind of control this is. lControlStyle As Long ' Applies only to controls of lControlType msoControlButton. Specifies the appearance of the control. vFaceID As Variant ' Used to specify the control face to be used. bBeginGroup As Boolean ' Whether this control has a separator bar above/left of it. lBefore As Long ' The index of the control to add the control before. sTooltip As String ' The tootip for this control. sShortcutKey As String ' The shortcut key, if any. This just displays the shortcut key. The shortcut key must be set in the caption. sTag As String ' String data type storage for the programmer's use. vParameter As Variant ' Variant data type storage for the programmer's use. lState As Long ' Specifies whether the button should be depressed or normal upon creation. rngListRange As Excel.Range ' The list used to populate dropdown and combobox controls. End Type

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Comments: Creates a set of CommandBars based on the entries in the ' wksCommandBars worksheet table. ' ' Date Developer Chap Action ' ---------------------------------------------------------------------------- ' 04/29/04 Rob Bovey Ch08 Initial version ' 05/14/04 Stephen Bullen Ch08 Set protection after all controls have been added ' Also added initial call to ResetCommandBars ' 05/28/04 Rob Bovey Ch12 Added error handling ' Public Function bBuildCommandBars() As Boolean

Const sSOURCE As String = "bBuildCommandBars()"

Dim bReturn As Boolean                          ' The function return value.
Dim uCommandBarAtr As COMMANDBAR_PROPERTIES     ' The attribute type structures for the CommandBars.
Dim uCtlProperties As CONTROL_PROPERTIES        ' The attribute type structures for the CommandBarControls.
Dim rngCurrentBarStart As Excel.Range           ' The first cell of the current command bar definition.
Dim rngCurrentBarStop As Excel.Range            ' The first cell of the current command bar definition.
Dim rngCurrentControlStart As Excel.Range       ' The cell holding the name of the control currently being added to the command bar.
Dim rngCurrentRow As Excel.Range                ' The current CommandBar definition table row being read.
Dim rngTemp As Excel.Range
Dim cbrCurrentBar As Office.CommandBar          ' The commandbar currently being built or modified.
Dim ctlTopControl As Office.CommandBarControl   ' Used to test the return value of ctlAddNewControl.

On Error GoTo ErrorHandler

' Assume success until an error is encountered.
bReturn = True

' Remove any previous command bars that may be left over from a crash.
ResetCommandBars

' Set a reference to the starting cell of the first command bar definition.
Set rngCurrentBarStart = wksCommandBars.Range(msRNG_TABLE_START).Offset(1, 0)

'# Edit By myfootprints.cn@gmail.com 2008-12-01
If rngCurrentBarStart Is Nothing Then
    'Set rngCurrentBarStart = wksCommandBars.Range("A1").Offset(1, 0)
    Err.Raise -1, sSOURCE, "The worksheet wksCommandBars is not been set correctly. Please check the name defenition."
End If
'# Edit End

' Start the Add CommandBar loop.
Do While rngCurrentBarStart.Row < mlMAX_TABLE_ROWS

    ' Find the last cell in the current CommandBar definition.
    Set rngCurrentBarStop = rngCurrentBarStart.End(xlDown)
    Set rngCurrentRow = rngCurrentBarStart.EntireRow
    
    ' Get the name of the CommandBar.
    uCommandBarAtr.sBarName = Trim$(rngCurrentBarStart.value)
    
    ' If a CommandBar by the name of sCurrentBar doesn't already exist then add one.
    If Not bCommandbarExists(uCommandBarAtr.sBarName, cbrCurrentBar) Then
    
        ' Load the CommandBar type structure with the properties of the CommandBar
        ' being added. Default values are loaded for unspecified properties.
        With uCommandBarAtr
            Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_POSITION))
            If IsEmpty(rngTemp.value) Then .lPosition = msoBarTop Else .lPosition = CLng(rngTemp.value)
            If .lPosition = msoBarPopup Then
                .bIsMenuBar = False
            Else
                .bIsMenuBar = CBool(Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_IS_MENU_BAR)).value)
            End If
            Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_VISIBLE))
            ' The Visible property *must* be false for msoBarPopup type CommandBars.
            If .lPosition = msoBarPopup Then .bVisible = False Else .bVisible = CBool(rngTemp.value)
            Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_WIDTH))
            ' The Width property only applies to msoBarFloating type CommandBars.
            If IsEmpty(rngTemp.value) Or .lPosition <> msoBarFloating Then .lWidth = mlPROPERTY_NOT_SET Else .lWidth = CLng(rngTemp.value)
            Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_PROTECTION))
            If IsEmpty(rngTemp.value) Then .lProtection = msoBarNoCustomize Else .lProtection = CLng(rngTemp.value)
            Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_IS_TEMPORARY))
            If IsEmpty(rngTemp.value) Then .bIsTemporary = True Else .bIsTemporary = CBool(rngTemp.value)
            Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_IS_ENABLED))
            If IsEmpty(rngTemp.value) Then .bIsEnabled = True Else .bIsEnabled = CBool(rngTemp.value)
        End With
        
        If Not bAddNewCommandBar(uCommandBarAtr) Then Err.Raise glHANDLED_ERROR
        
        Set cbrCurrentBar = Application.CommandBars(uCommandBarAtr.sBarName)
    
    End If

    ' Set a reference to the postion of the first control for sCurrentBar
    Set rngCurrentControlStart = rngCurrentBarStart.Offset(0, 1).End(xlDown)

    ' The add controls loop.
    Do While rngCurrentControlStart.Row < rngCurrentBarStop.Row
    
        ' Load the control attribute type structure.
        If Not bLoadControlAttributes(rngCurrentControlStart, uCtlProperties, cbrCurrentBar) Then Err.Raise glHANDLED_ERROR
        
        ' If sCurrentControl has sub-controls it will be a CommandBarPopup.
        If Len(rngCurrentControlStart.Offset(1, 1).value) > 0 Then
        
            ' Check to see if it exists already. Add it if it doesn't.
            If Not bControlExists(cbrCurrentBar, uCtlProperties.sControlName) Then
                Set ctlTopControl = Nothing
                Set ctlTopControl = ctlAddNewControl(cbrCurrentBar, uCtlProperties)
                If ctlTopControl Is Nothing Then Err.Raise glHANDLED_ERROR
            Else
                Set ctlTopControl = cbrCurrentBar.Controls(uCtlProperties.sControlName)
            End If
            
            ' Add the sub-controls the the CommandBarPopup.
            If Not bAddSubControls(ctlTopControl, rngCurrentControlStart, rngCurrentBarStop.Row) Then Err.Raise glHANDLED_ERROR
            
        Else    ' If sCurrentControl has no sub-controls then set its properties directly.
        
            ' Only add it if it doesn't already exist.
            If Not bControlExists(cbrCurrentBar, uCtlProperties.sControlName) Then
                Set ctlTopControl = Nothing
                Set ctlTopControl = ctlAddNewControl(cbrCurrentBar, uCtlProperties)
                If ctlTopControl Is Nothing Then Err.Raise glHANDLED_ERROR
            End If
            
        End If
        
        ' Reset the starting point for the next control.
        If Len(rngCurrentControlStart.Offset(1, 0).value) > 0 Then
            Set rngCurrentControlStart = rngCurrentControlStart.Offset(1, 0)
        Else
            Set rngCurrentControlStart = rngCurrentControlStart.End(xlDown)
        End If
        
    Loop

    ' CommandBar width and protection can't be set until after the controls have been added.
    If uCommandBarAtr.lWidth > 0 Then cbrCurrentBar.Width = uCommandBarAtr.lWidth
    If Not cbrCurrentBar.BuiltIn Then cbrCurrentBar.Protection = uCommandBarAtr.lProtection

    ' Reset the starting point for the next command bar.
    Set rngCurrentBarStart = rngCurrentBarStop.End(xlDown)

Loop

ErrorExit:

' This is required to get any FaceID pictures that we've copied out of
' the clipboard (Application.CutCopyMode = False alone doesn't work).
wksCommandBars.Range("A1").Copy
Application.CutCopyMode = False
bBuildCommandBars = bReturn
Exit Function

ErrorHandler: If Err.Number <> glHANDLED_ERROR Then Err.Description = Err.Description & " (" & sSOURCE & ")" bReturn = False If bCentralErrorHandler(msMODULE, sSOURCE) Then Stop Resume Else Resume ErrorExit End If End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Comments: Reads the CommandBars table and removes all custom CommandBars and ' controls defined there. ' This code makes the implicit assumption that cascading submenus ' are either 100% built-in or 100% custom. ' ' Date Developer Chap Action ' -------------------------------------------------------------------------- ' 04/29/04 Rob Bovey Ch08 Initial version ' 05/28/04 Rob Bovey Ch12 Added error handling ' Public Sub ResetCommandBars()

Dim rngCurrentBarStart As Excel.Range       ' The first cell of the current command bar definition.
Dim rngCurrentBarStop As Excel.Range        ' The first cell of the current command bar definition.
Dim rngCurrentControlStart As Excel.Range   ' The cell holding the name of the control currently being added to the command bar.
Dim lSubMenuCount As Long
Dim cbrBar As Office.CommandBar
Dim ctlMenuControl As Office.CommandBarControl
Dim sCurrentBar As String                   ' Holds the name of the command bar currently being built.
Dim sCurrentControl As String               ' The name of the Control currently being deleted.
Dim sSubMenu As String                      ' The current submenu.

If gbDEBUG_MODE Then
    On Error GoTo 0
Else
    On Error Resume Next
End If

' Set a reference to the starting cell of the first command bar definition.
Set rngCurrentBarStart = wksCommandBars.Range(msRNG_TABLE_START).Offset(1, 0)

'# Edit By myfootprints.cn@gmail.com 2088-8-2
If rngCurrentBarStart Is Nothing Then
    ' If rngCurrentBarStart is still nothing, give it a default value
    Set rngCurrentBarStart = wksCommandBars.Range("A1").Offset(1, 0)
End If
'# Edit End

' Start processing the CommandBars table.
Do While rngCurrentBarStart.Row < mlMAX_TABLE_ROWS

    ' Find the last cell in the current command bar definition.
    Set rngCurrentBarStop = rngCurrentBarStart.End(xlDown)
    
    ' Grab the name of the current command bar.
    sCurrentBar = Trim$(rngCurrentBarStart.value)

    ' Only continue if the CommandBar has not already been deleted.
    If bCommandbarExists(sCurrentBar, cbrBar) Then

        ' If the whole CommandBar is custom then just delete it.
        If Not cbrBar.BuiltIn Then
            cbrBar.Delete
        Else    ' Otherwise loop through and check each control.
        
            ' Set a reference to the postion of the first control for sCurrentBar
            Set rngCurrentControlStart = rngCurrentBarStart.Offset(0, 1).End(xlDown)
    
            ' Loop the top-level controls.
            Do While rngCurrentControlStart.Row < rngCurrentBarStop.Row
            
                ' The name of the control to check.
                sCurrentControl = Trim$(rngCurrentControlStart.value)

                ' Only continue if the control has not already been deleted.
                If bControlExists(cbrBar, sCurrentControl) Then
                
                    Set ctlMenuControl = cbrBar.Controls(sCurrentControl)
                            
                    ' If it's custom delete it, otherwise continue.
                    If Not ctlMenuControl.BuiltIn Then
                        ctlMenuControl.Delete
                    Else
                    
                        ' If the top-level control has sub-controls, loop them.
                        If Len(rngCurrentControlStart.Offset(1, 1).value) > 0 Then
                        
                            lSubMenuCount = 1
                            
                            Do While rngCurrentControlStart.Offset(lSubMenuCount, 1).Row < rngCurrentBarStop.Row
                                sSubMenu = Trim$(rngCurrentControlStart.Offset(lSubMenuCount, 1).value)
                                If Len(sSubMenu) > 0 Then
                                    ' Delete the submenu if it isn't built-in.
                                    With ctlMenuControl.Controls(sSubMenu)
                                        If Not .BuiltIn Then .Delete
                                    End With
                                End If
                                lSubMenuCount = lSubMenuCount + 1
                            Loop
                            
                        End If
                    
                    End If
                
                End If
                
                ' Reset the starting point for the next control.
                If Len(rngCurrentControlStart.Offset(1, 0).value) > 0 Then
                    Set rngCurrentControlStart = rngCurrentControlStart.Offset(1, 0)
                Else
                    Set rngCurrentControlStart = rngCurrentControlStart.End(xlDown)
                End If
                
            Loop
        
        End If
        
    End If
    
    ' Reset the starting point for the next command bar.
    Set rngCurrentBarStart = rngCurrentBarStop.End(xlDown)
   
Loop
   

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Comments: Adds sub-controls to a CommandBarPopup control. ' ' Arguments: ctlTopControl The CommandBarPopup to which controls will ' be added. ' rngCurControlStart The cell in wksCommandBars at which the ' definition of ctlTopControl begins. ' lBarStopRow The last row in the current CommandBar ' definition. ' ' Date Developer Chap Action ' ---------------------------------------------------------------------------- ' 04/29/04 Rob Bovey Ch08 Initial version ' 05/28/04 Rob Bovey Ch12 Added error handling ' Private Function bAddSubControls(ByRef ctlTopControl As Office.CommandBarPopup, ByRef rngCurControlStart As Excel.Range, ByVal lBarStopRow As Long) As Boolean

Const sSOURCE As String = "bAddSubControls()"

Dim bReturn As Boolean
Dim uCtlProperties As CONTROL_PROPERTIES
Dim rngCurLevel1Control As Excel.Range          ' The table definition range of the Level1Control being added.
Dim rngCurLevel2Control As Excel.Range          ' The table definition range of the Level2Control being added.
Dim lTopControlStopRow As Long                  ' The last row in the top control's table definition.
Dim lSubMenuItemStopRow As Long                 ' The last row in the Level2Control control's table definition.
Dim ctlControlItem As Office.CommandBarControl  ' A reference to the first level control being added (used when level 2 controls are specified).
Dim ctlReturn As Office.CommandBarControl       ' Tests the return value of the ctlAddNewControl function.

On Error GoTo ErrorHandler

' Assume success until an error is encountered.
bReturn = True

' Set a reference to the table definition range of the Level1Control being added.
Set rngCurLevel1Control = rngCurControlStart.Offset(1, 1)

' Grab the number of the last row in the top control's table definition.
lTopControlStopRow = rngCurControlStart.End(xlDown).Row

' Make sure we don't read past the end of the command bar definition
If lTopControlStopRow > lBarStopRow Then lTopControlStopRow = lBarStopRow

' Add sub-controls loop.
Do While rngCurLevel1Control.Row < lTopControlStopRow
    
    ' Load the control attribute type structure.
    If Not bLoadControlAttributes(rngCurLevel1Control, uCtlProperties, ctlTopControl) Then Err.Raise glHANDLED_ERROR
    
    ' If True, it's an msoControlPopup, otherwise it's an msoControlButton.
    If Len(rngCurLevel1Control.Offset(1, 0).value) = 0 And Len(rngCurLevel1Control.Offset(1, 1).value) > 0 Then
    
        ' Add the msoControlPopup.
        If Not bControlExists(ctlTopControl, uCtlProperties.sControlName) Then
            Set ctlControlItem = Nothing
            Set ctlControlItem = ctlAddNewControl(ctlTopControl, uCtlProperties)
            If ctlControlItem Is Nothing Then Err.Raise glHANDLED_ERROR
        Else
            ' Set a reference to the existing control
            Set ctlControlItem = ctlTopControl.Controls(uCtlProperties.sControlName)
        End If
        
        ' Grab the last row in the Level 2 control's table definition.
        If Len(rngCurLevel1Control.Offset(2, 1).value) = 0 Then
            ' Only a single level 2 control.
            lSubMenuItemStopRow = rngCurLevel1Control.Offset(1, 1).Row
        Else
            ' Multiple level 2 controls.
            lSubMenuItemStopRow = rngCurLevel1Control.Offset(1, 1).End(xlDown).Row
        End If
        
        ' Add the msoControlPopup sub-controls.
        If lSubMenuItemStopRow < lTopControlStopRow Then
        
            ' Set a reference to the table definition range of the Level2Control being added.
            Set rngCurLevel2Control = rngCurLevel1Control.Offset(1, 1)
            
            ' msoControlPopup sub-controls loop.
            Do While rngCurLevel2Control.Row <= lSubMenuItemStopRow
            
                ' Load the control attribute type structure.
                If Not bLoadControlAttributes(rngCurLevel2Control, uCtlProperties, ctlControlItem) Then Err.Raise glHANDLED_ERROR
                
                ' Add the sub-control.
                Set ctlReturn = Nothing
                Set ctlReturn = ctlAddNewControl(ctlControlItem, uCtlProperties)
                If ctlReturn Is Nothing Then Err.Raise glHANDLED_ERROR
                
                ' Increment the range for the next sub-control.
                Set rngCurLevel2Control = rngCurLevel2Control.Offset(1, 0)
                
            Loop
    
        End If
            
        ' Increment the range for the next level 1 control.
        Set rngCurLevel1Control = rngCurLevel1Control.End(xlDown)
        
    Else    ' It's an msoControlButton, assign all properties directly.

        If Not bControlExists(ctlTopControl, uCtlProperties.sControlName) Then
            Set ctlControlItem = Nothing
            Set ctlControlItem = ctlAddNewControl(ctlTopControl, uCtlProperties)
            If ctlControlItem Is Nothing Then Err.Raise glHANDLED_ERROR
        End If
        
        ' Increment the range for the next level 1 control.
        Set rngCurLevel1Control = rngCurLevel1Control.Offset(1, 0)
        
    End If

Loop

ErrorExit:

bAddSubControls = bReturn
Exit Function

ErrorHandler: If Err.Number <> glHANDLED_ERROR Then Err.Description = Err.Description & " (" & sSOURCE & ")" bReturn = False If bCentralErrorHandler(msMODULE, sSOURCE) Then Stop Resume Else Resume ErrorExit End If End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Comments: Adds a new CommandBar. ' ' Arguments: uBarProperties The type structure containing all the ' CommandBar's properties. ' ' Date Developer Chap Action ' ---------------------------------------------------------------------------- ' 04/29/04 Rob Bovey Ch08 Initial version ' 05/14/04 Stephen Bullen Ch08 Moved Protection setting to the end of main ' procedure to avoid crash when pasting pictures. ' 05/28/04 Rob Bovey Ch12 Added error handling ' Private Function bAddNewCommandBar(ByRef uBarProperties As COMMANDBAR_PROPERTIES) As Boolean

Const sSOURCE As String = "bAddNewCommandBar()"

Dim bReturn As Boolean
Dim cbrBar As Office.CommandBar

On Error GoTo ErrorHandler

' Assume success until an error is encountered.
bReturn = True

Set cbrBar = Nothing

With uBarProperties
    Set cbrBar = Application.CommandBars.Add(.sBarName, .lPosition, .bIsMenuBar, .bIsTemporary)
End With

' Set any properties that could not be set during CommandBar creation.
With uBarProperties
    ' You can't set the visible property for Popup CommandBars.
    If .lPosition <> msoBarPopup Then cbrBar.Visible = .bVisible
    If .lWidth <> mlPROPERTY_NOT_SET Then cbrBar.Width = .lWidth
    cbrBar.Enabled = .bIsEnabled
End With

ErrorExit:

bAddNewCommandBar = bReturn
Exit Function

ErrorHandler: If Err.Number <> glHANDLED_ERROR Then Err.Description = Err.Description & " (" & sSOURCE & ")" bReturn = False If bCentralErrorHandler(msMODULE, sSOURCE) Then Stop Resume Else Resume ErrorExit End If End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Comments: Determines if the specified CommandBar already exists. ' ' Arguments: sBarName The name of the CommandBar to look for. ' cbrBar Returns a reference to the CommandBar if it exists. ' ' Returns: Boolean True if the CommandBar already exists, ' False otherwise. ' ' Date Developer Chap Action ' ---------------------------------------------------------------------------- ' 04/29/04 Rob Bovey Ch08 Initial version ' Private Function bCommandbarExists(ByVal sBarName As String, ByRef cbrBar As Office.CommandBar) As Boolean

If IsNumeric(sBarName) Then
    ' If an index was passed for the CommandBar name, check for it directly.
    On Error Resume Next
        Set cbrBar = Application.CommandBars(CLng(sBarName))
    On Error GoTo 0
Else
    ' Otherwise loop the CommandBars collection and look for a name match.
    For Each cbrBar In Application.CommandBars
        ' If a match is located, exit the loop.
        If StrComp(cbrBar.Name, sBarName, vbTextCompare) = 0 Then Exit For
    Next cbrBar
End If

bCommandbarExists = Not cbrBar Is Nothing

End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Comments: Adds a CommandBarControl to a CommandBar or CommandBarPopup. ' ' Arguments: objTarget The CommandBar or CommandBarPopup to add the ' control to. ' uCtlProperties A type structure containing the properties ' of the control to be added. ' ' Returns: CommandBarControl An object reference to the control that was ' created. ' ' Date Developer Chap Action ' ---------------------------------------------------------------------------- ' 04/29/04 Rob Bovey Ch08 Initial version ' 05/13/04 Stephen Bullen Ch08 Allow built-in controls to have custom faces. ' 05/28/04 Rob Bovey Ch12 Added error handling ' Private Function ctlAddNewControl(ByRef objTarget As Object, ByRef uCtlProperties As CONTROL_PROPERTIES) As Office.CommandBarControl

Const sSOURCE As String = "ctlAddNewControl()"
Const sDOUBLE As String = "Double"
Const sSTRING As String = "String"

Static bSetOnce As Boolean

Dim rngCell As Excel.Range
Dim lSeparator As Long
Dim objButton As Object
Dim ctlControl As Office.CommandBarControl

If gbDEBUG_MODE Then
    On Error GoTo 0
Else
    On Error GoTo ErrorHandler
End If

With uCtlProperties
    ' Different .Add calls are required depending on whether the control is a
    ' custom control and whether or not the Before property was specified.
    If .lControlID = mlCUSTOM_CONTROL Then
        ' This is a custom control, specify its Parameter property.
        If .lBefore = mlPROPERTY_NOT_SET Then
            ' Before not specified.
            Set ctlControl = objTarget.Controls.Add(.lControlType, .lControlID, .vParameter, , .bIsTemporary)
        Else
            ' Before was specified.
            Set ctlControl = objTarget.Controls.Add(.lControlType, .lControlID, .vParameter, .lBefore, .bIsTemporary)
        End If
    Else
        ' This is a built-in control, do not specify its Type property.
        If .lBefore = mlPROPERTY_NOT_SET Then
            ' Before not specified.
            Set ctlControl = objTarget.Controls.Add(, .lControlID, .vParameter, , .bIsTemporary)
        Else
            ' Before was specified.
            Set ctlControl = objTarget.Controls.Add(, .lControlID, .vParameter, .lBefore, .bIsTemporary)
        End If
    End If
End With

If uCtlProperties.lControlID = mlCUSTOM_CONTROL Then ctlControl.Caption = uCtlProperties.sControlName
If uCtlProperties.lControlStyle <> mlPROPERTY_NOT_SET Then ctlControl.Style = uCtlProperties.lControlStyle
If uCtlProperties.lWidth <> mlPROPERTY_NOT_SET Then ctlControl.Width = uCtlProperties.lWidth

' These properties are set for all controls.
ctlControl.BeginGroup = uCtlProperties.bBeginGroup
ctlControl.Enabled = uCtlProperties.bIsEnabled
If Len(uCtlProperties.sTooltip) > 0 Then ctlControl.TooltipText = uCtlProperties.sTooltip
If Len(uCtlProperties.sShortcutKey) > 0 Then
    ctlControl.ShortcutText = uCtlProperties.sShortcutKey
    If Not bSetOnce Then
        ' The ShortcutText property will have no effect unless these two
        ' CommandBar properties are turned on. This only needs to be done
        ' once, hence the static bSetOnce flag variable.
        With Application.CommandBars
            .DisplayTooltips = True
            .DisplayKeysInTooltips = True
        End With
        bSetOnce = True
    End If
End If
If Len(uCtlProperties.sTag) > 0 Then ctlControl.Tag = uCtlProperties.sTag

If TypeName(uCtlProperties.vFaceID) = sDOUBLE Then
    ' The ID number of a built-in button FaceID.
    ctlControl.FaceId = CLng(uCtlProperties.vFaceID)
ElseIf TypeName(uCtlProperties.vFaceID) = sSTRING Then

    ' A bitmap (and maybe mask) which must be located on the CommandBar definition worksheet.
    lSeparator = InStr(1, uCtlProperties.vFaceID, "/")
    
    If lSeparator > 0 Then  ' A picture and a transparency mask, separated by a /.

        ' Setting the picture and mask is only supported in Excel 2002 and up, so check here.
        If Val(Application.Version) >= 10 Then
        
            ' Excel 2002 or higher, we can set the picture and mask.
            Set objButton = ctlControl

            ' Copy the picture to the clipboard and set as the Picture.
            wksCommandBars.Shapes(Trim$(Left$(uCtlProperties.vFaceID, lSeparator - 1))).CopyPicture xlScreen, xlBitmap
            objButton.Picture = PastePicture(xlBitmap)

            ' Copy the mask to the clipboard and set as the Mask.
            wksCommandBars.Shapes(Trim$(Mid$(uCtlProperties.vFaceID, lSeparator + 1))).CopyPicture xlScreen, xlBitmap
            objButton.Mask = PastePicture(xlBitmap)
            
        Else
            ' Excel 97/2000, so just copy/paste the picture.
            wksCommandBars.Shapes(Trim$(Left$(uCtlProperties.vFaceID, lSeparator - 1))).CopyPicture
            ctlControl.PasteFace
        End If
        
    Else
        ' Just a picture, so copy to the clipboard and paste to the button.
        wksCommandBars.Shapes(Trim$(uCtlProperties.vFaceID)).CopyPicture
        ctlControl.PasteFace
    End If
    
End If

' These properties are set for custom controls only.
If uCtlProperties.lControlID = mlCUSTOM_CONTROL Then

    If Len(uCtlProperties.sOnAction) > 0 Then ctlControl.OnAction = uCtlProperties.sOnAction

    If uCtlProperties.lState <> mlPROPERTY_NOT_SET Then ctlControl.State = uCtlProperties.lState
    
    If uCtlProperties.lControlType = msoControlComboBox Or uCtlProperties.lControlType = msoControlDropdown Then
        If Not uCtlProperties.rngListRange Is Nothing Then
            For Each rngCell In uCtlProperties.rngListRange
                ctlControl.AddItem rngCell.value
            Next rngCell
        End If
    End If
        
End If

' Return an object reference to the new control.
Set ctlAddNewControl = ctlControl
Exit Function

ErrorHandler: If Err.Number <> glHANDLED_ERROR Then Err.Description = Err.Description & " (" & sSOURCE & ")" Set ctlAddNewControl = Nothing End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Comments: Determines whether a CommandBarControl with the specified caption ' exists on the specified CommandBar or CommandBarPopup. ' ' Arguments: objTarget The CommandBar or CommandBarPopup to look for ' the control on. ' sFindCaption The caption of the control to look for. ' ' Returns: Boolean True if the control exists, False otherwise. ' ' Date Developer Chap Action ' ---------------------------------------------------------------------------- ' 04/29/04 Rob Bovey Ch08 Initial version ' Private Function bControlExists(ByRef objTarget As Object, ByVal sFindCaption As String) As Boolean

Const sAMPERSAND As String = "&"

Dim bLocated As Boolean
Dim objFunc As Excel.WorksheetFunction
Dim ctlControls As Office.CommandBarControls    ' The collection being searched.
Dim ctlControl As Office.CommandBarControl      ' Collection counter.
Dim sCompareCaption As String                  ' The caption on the current control in the loop.

Set objFunc = Application.WorksheetFunction

' Remove the accelerator symbol if there is one.
sFindCaption = objFunc.Substitute(sFindCaption, sAMPERSAND, "")

Set ctlControls = objTarget.Controls

' Loop through each control on the specified object and try to match sFindCaption.
For Each ctlControl In ctlControls
    ' Remove the accelerator symbol if there is one.
    sCompareCaption = objFunc.Substitute(ctlControl.Caption, sAMPERSAND, "")
    ' If a match is located, return True and exit.
    If StrComp(sCompareCaption, sFindCaption, vbTextCompare) = 0 Then
        bLocated = True
        Exit For
    End If
Next ctlControl

bControlExists = bLocated

End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Comments: Loads a CONTROL_PROPERTIES type structure with values for a ' CommandBarControl from the wksCommandBars table. ' ' Arguments: rngStartCell The cell containing the name of the control ' uCtlProperties The type structure to be loaded with the control ' properties. ' objParent A reference to the parent control of the control ' being loaded. ' ' Date Developer Chap Action ' -------------------------------------------------------------------------- ' 04/29/04 Rob Bovey Ch08 Initial version ' 05/28/04 Rob Bovey Ch12 Added error handling ' Private Function bLoadControlAttributes(ByRef rngStartCell As Excel.Range, ByRef uCtlProperties As CONTROL_PROPERTIES, ByRef objParent As Object) As Boolean

Const sSOURCE As String = "bLoadControlAttributes()"

Dim bReturn As Boolean
Dim rngCurrentRow As Excel.Range
Dim rngTemp As Excel.Range
Dim sTemp As String

On Error GoTo ErrorHandler

' Assume success until an error is encountered.
bReturn = True

Set rngCurrentRow = rngStartCell.EntireRow

' Load the control properties type structure. Default values are loaded here for
' unspecified properties.
With uCtlProperties

    .sControlName = Trim$(rngStartCell.value)
    
    Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_WIDTH))
    If IsEmpty(rngTemp.value) Then .lWidth = mlPROPERTY_NOT_SET Else .lWidth = CLng(rngTemp.value)
    
    Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_IS_TEMPORARY))
    If IsEmpty(rngTemp.value) Then .bIsTemporary = True Else .bIsTemporary = CBool(rngTemp.value)
    
    Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_IS_ENABLED))
    If IsEmpty(rngTemp.value) Then .bIsEnabled = True Else .bIsEnabled = CBool(rngTemp.value)
    
    ' If no workbook was specified in the OnAction entry, assume ThisWorkbook.
    sTemp = Trim$(Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_ONACTION)))
    If Len(sTemp) = 0 Then
        .sOnAction = vbNullString
    ElseIf InStr(sTemp, "!") = 0 Then
        .sOnAction = ThisWorkbook.Name & "!" & sTemp
    Else
        .sOnAction = sTemp
    End If
    
    Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_CONTROL_ID))
    If IsEmpty(rngTemp.value) Then .lControlID = mlCUSTOM_CONTROL Else .lControlID = CLng(rngTemp.value)
    
    If .lControlID = mlCUSTOM_CONTROL Then
        Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_CONTROL_TYPE))
        If IsEmpty(rngTemp.value) Then .lControlType = msoControlButton Else .lControlType = CLng(rngTemp.value)
    Else
        .lControlType = mlPROPERTY_NOT_SET
    End If
    
    If .lControlType <> mlPROPERTY_NOT_SET Then
        ' The Style property only applies to controls of type msoControlButton, msoControlComboBox, and msoControlDropdown.
        Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_CONTROL_STYLE))
        If .lControlType <> msoControlButton And .lControlType <> msoControlComboBox And .lControlType <> msoControlDropdown Then
            .lControlStyle = mlPROPERTY_NOT_SET
        ElseIf IsEmpty(rngTemp.value) Then
            If .lControlType = msoControlButton Then
                .lControlStyle = msoButtonAutomatic
            ElseIf .lControlType = msoControlComboBox Then
                .lControlStyle = msoComboNormal
            End If
        Else
            .lControlStyle = CLng(rngTemp.value)
        End If
    Else
        .lControlStyle = mlPROPERTY_NOT_SET
    End If
    
    .vFaceID = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_FACE_ID)).value
    .bBeginGroup = CBool(Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_BEGIN_GROUP)).value)
    
    Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_BEFORE))
    .lBefore = lConvertBefore(objParent, rngTemp.value)
    
    .sTooltip = Trim$(Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_TOOLTIP)).value)
    
    If .lControlID = mlCUSTOM_CONTROL Then
        .sShortcutKey = Trim$(Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_SHORTCUT_TEXT)).value)
    Else
        .sShortcutKey = vbNullString
    End If
    
    .sTag = Trim$(Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_TAG)).value)
    .vParameter = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_PARAMETER)).value
    
    ' The State property only applies to custom controls of type msoControlButton.
    If (.lControlID = mlCUSTOM_CONTROL) And (.lControlType = msoControlButton) Then
        Set rngTemp = Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_STATE))
        If IsEmpty(rngTemp.value) Then
            .lState = msoButtonUp
        Else
            .lState = CLng(rngTemp.value)
        End If
    Else
        .lState = mlPROPERTY_NOT_SET
    End If
    
    ' The ListRange property only applies to controls of type msoControlComboBox or msoControlDropDown.
    If .lControlType = msoControlComboBox Or .lControlType = msoControlDropdown Then
        sTemp = Trim$(Application.Intersect(rngCurrentRow, wksCommandBars.Range(msCOL_LIST_RANGE)).value)
        If Len(sTemp) > 0 Then
            Set .rngListRange = wksCommandBars.Range(sTemp)
        Else
            Set .rngListRange = Nothing
        End If
    End If
    
End With

ErrorExit:

bLoadControlAttributes = bReturn
Exit Function

ErrorHandler: If Err.Number <> glHANDLED_ERROR Then Err.Description = Err.Description & " (" & sSOURCE & ")" bReturn = False If bCentralErrorHandler(msMODULE, sSOURCE) Then Stop Resume Else Resume ErrorExit End If End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Comments: Converts a control name into its position index on the CommandBar. ' ' Arguments: objBar The CommandBar or CommandBarPopup that the control is ' located on. ' vBefore The name to convert. ' ' Returns: Long If vBefore is a String, the function returns the ' position index of the control with that name. ' If vBefore is numeric, the function returns it converted ' to a Long data type. If vBefore is empty, the function ' returns mlPROPERTY_NOT_SET. ' ' Date Developer Chap Action ' -------------------------------------------------------------------------- ' 04/29/04 Rob Bovey Ch08 Initial version ' Private Function lConvertBefore(ByRef objBar As Object, ByVal vBefore As Variant) As Long

' This is the default.
lConvertBefore = mlPROPERTY_NOT_SET

If Len(vBefore) = 0 Then
    ' If it's empty, return not set.
    lConvertBefore = mlPROPERTY_NOT_SET
ElseIf IsNumeric(vBefore) Then
    ' If it's already numeric, just return it as a long.
    lConvertBefore = CLng(vBefore)
Else    ' Look for a control with that name. Return mlPROPERTY_NOT_SET if not found.
    On Error Resume Next
        lConvertBefore = mlPROPERTY_NOT_SET
        lConvertBefore = objBar.Controls(Trim$(CStr(vBefore))).Index
    On Error GoTo 0
End If

End Function