<style type="text/css">
《Excel 专业开发》提供了很多很好的开发框架,以表格驱动来建立自定义菜单就是其中一个很好的框架。
使用表格驱动建立菜单,可以很方便很简单地管理自定义菜单,节约开发与维护成本。
如果要建立如下图所示的菜单项:
只需要按如下格式输入自定义菜单信息:
Command Bar Name[1] | Control Caption[2] | Control Caption[3] | Control Caption[4] | Position[5] | IsMenubar[6] | Visible[7] | Width[8] | Protection[9] | IsTemporary[10] | IsEnabled[11] | OnAction[12] | Control ID[13] | Control Type[14] | Control Style[15] | Face ID[16] | Begin Group[17] | Before[18] | Tooltip[19] | Shortcut Text[20] | Tag[21] | Parameter[22] | State[23] | ListRange[24] | Lists[25] |
Worksheet Menu Bar | ||||||||||||||||||||||||
mf-Utility | 10 | Window | ||||||||||||||||||||||
拆分表格(&S) | MenuSplitTable | 461 | Split one table to more tables | |||||||||||||||||||||
多表模式拆分记录(&R) | MenuSplitTable_MultiSheets | 461 | Split one table to more tables with multi sheets | |||||||||||||||||||||
多表模式拆分记录二(&M) | MenuSplitTable_MultiSheets_Mode2 | 461 | Split one table to more tables with multi sheets | |||||||||||||||||||||
导出记录(&E) | MenuExtractRecords | 659 | Extract records | |||||||||||||||||||||
多表模式导出记录(&T) | MenuExtractRecords_MultiSheets | 659 | Extract records with multi-sheets | |||||||||||||||||||||
删除文件夹(&D) | FALSE | MenuDeleteFolders | 2500 | TRUE | Delete folders | |||||||||||||||||||
在线帮助(&H) | MenuOnlineHelp | 4087 | TRUE | Online help (Website:http://www.myfootprints.cn) | ||||||||||||||||||||
退出(&X) | AppExit | 868 | TRUE | Exit My Footprints Utility | ||||||||||||||||||||
Stop | ||||||||||||||||||||||||
以下程序(MCommandBars.bas)将会根据如上输入的信息,自动构建出自定义的菜单。当需要更改、删除或者添加自定义的菜单项时,只需要在上面的表格中修改即可,而不需要更改程序代码。
' ' 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