'***************************************************************************
'*
'* APPLICATION: Command Bar Lister
'* AUTHOR & DATE: John Green: Execuplan Consulting Pty. Ltd.
'* 10th June 1999
'*
'* CONTACT: jgreen@enternet.com.au
'*
'* DESCRIPTION: Lists command bars, command bar controls and button faces.
'* The code was derived from code presented in "Excel 2000
'* VBA Programmer's Reference", Wrox Press, modified according
'* to a suggestion from Bill Manville to use a recursive function
'* to list the control hierarchy.
'*
'* THIS MODULE: Contains all code apart from the Workbook Open and Close
'* event procedures.
'*
'* SUB PROCEDURES:
'* ListAllControls Lists all command bars and their controls
'* ListAllFaces Lists all Faces and FaceIds
'* ListPopUps Lists all short cut command bars
'* ShowHelp Displays help form
'*
'* FUNCTIONS:
'*ListControls Recursive Function to list controls
'*IsEmptyWorksheet Checks that listing is going to an empty worksheet
'***************************************************************************
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: ListAllControls
'''
''' Purpose: Processes all command bars and calls ListControls function
'''
''' Arguments: None
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 10 Jun 99 John Green Created
'''
Sub ListAllControls()
Dim cb As CommandBar
Dim rng As Range
Dim ctl As CommandBarControl
If Not IsEmptyWorksheet(ActiveSheet) Then Exit Sub
Set rng = Range("A1")
Application.ScreenUpdating = False
For Each cb In Application.CommandBars
Application.StatusBar = "Processing Bar " & cb.Name
rng.Value = cb.Name
For Each ctl In cb.Controls
Set rng = rng.Offset(ListControls(ctl, rng))
Next ctl
Next cb
Range("A:I").EntireColumn.AutoFit
Application.StatusBar = False
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Function: ListControls
'''
''' Purpose: Lists control Caption, Type, Face and FaceId. Calls itself
''' when a control contains other controls. Ignores the contents
''' of controls that do not contain listable control information.
''' Returns offset of row after added controls.
'''
''' Arguments: ctl - control object
''' rng - current starting cell (Range object) for listing
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 10 Jun 99 John Green Created
'''
Function ListControls(ctl As CommandBarControl, rng As Range) As Long
Dim lngOffset As Long 'Tracks current row relative to rng
Dim ctlSub As CommandBarControl 'Control contained in ctl
On Error Resume Next
lngOffset = 0
rng.Offset(lngOffset, 1).Value = ctl.Caption
rng.Offset(lngOffset, 2).Value = ctl.Type
'Attempt to copy control face. If error, don't paste
ctl.CopyFace
If Err.Number = 0 Then
ActiveSheet.Paste rng.Offset(lngOffset, 3)
rng.Offset(lngOffset, 3).Value = ctl.FaceId
End If
Err.Clear
'Check Control Type
Select Case ctl.Type
Case 1, 2, 4, 6, 7, 13, 18
'Do nothing for these control types
Case Else
'Call function recursively if current control contains other controls
For Each ctlSub In ctl.Controls
lngOffset = lngOffset + _
ListControls(ctlSub, rng.Offset(lngOffset, 2))
Next ctlSub
lngOffset = lngOffset - 1
End Select
ListControls = lngOffset + 1
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Function: IsEmptyWorksheet
'''
''' Purpose: Checks that worksheet is empty. Returns True or False
'''
''' Arguments: sht - Worksheet object
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 10 Jun 99 John Green Created
'''
Function IsEmptyWorksheet(sht As Object) As Boolean
If TypeName(sht) = "Worksheet" Then
If WorksheetFunction.CountA(sht.UsedRange) = 0 Then
IsEmptyWorksheet = True
Exit Function
End If
End If
MsgBox "Please make sure that an empty worksheet is active", vbCritical, _
"Warning"
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: ListAllFaces
'''
''' Purpose: Processes all FaceId numbers and lists face images
'''
''' Arguments: None
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 10 Jun 99 John Green Created
'''
Sub ListAllFaces()
Dim i As Integer 'Tracks current FaceId
Dim j As Integer 'Tracks current column in worksheet
Dim k As Integer 'Tracks current row in worksheet
Dim ctl As CommandBarControl
Dim cb As CommandBar
If Not IsEmptyWorksheet(ActiveSheet) Then Exit Sub
On Error Resume Next
Application.ScreenUpdating = False
'Create temporary command bar with single control button
'to hold control button face to be copied to worksheet
Set cb = CommandBars.Add(Position:=msoBarFloating, _
MenuBar:=False, _
temporary:=True)
Set ctl = cb.Controls.Add(Type:=msoControlButton, _
temporary:=True)
k = 1
Do While Err.Number = 0
For j = 1 To 10
i = i + 1
Application.StatusBar = "FaceID = " & i
'Set control button to current FaceId
ctl.FaceId = i
'Attempt to copy Face image to worksheet
ctl.CopyFace
'Abandont For loop and Do loop if there is an error
If Err.Number <> 0 Then Exit For
ActiveSheet.Paste Cells(k, j + 1)
Cells(k, j).Value = i
Next j
k = k + 1
Loop
Application.StatusBar = False
cb.Delete
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: ListPopups
'''
''' Purpose: Lists all command bars of type msoBarTypePopup and their controls.
''' Only lists controls at the top level. Does not list any controls
''' contained in the top level controls.
'''
''' Arguments: None
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 10 Jun 99 John Green Created
'''
Sub ListPopups()
Dim ctl As CommandBarControl
Dim cb As CommandBar
Dim intRow As Integer 'Tracks row in worksheet
If Not IsEmptyWorksheet(ActiveSheet) Then Exit Sub
On Error Resume Next
Application.ScreenUpdating = False
Cells(1, 1).Value = "CommandBar"
Cells(1, 2).Value = "Control"
Cells(1, 3).Value = "FaceID"
Cells(1, 4).Value = "ID"
Range("A1:D1").Font.Bold = True
intRow = 2
For Each cb In CommandBars
Application.StatusBar = "Processing Bar " & cb.Name
'Only list command bar if type is Popup
If cb.Type = msoBarTypePopup Then
Cells(intRow, 1).Value = cb.Name
intRow = intRow + 1
'List controls on command bar
For Each ctl In cb.Controls
Cells(intRow, 2).Value = ctl.Caption
ctl.CopyFace
If Err.Number = 0 Then
ActiveSheet.Paste Cells(intRow, 3)
Cells(intRow, 3).Value = ctl.FaceId
End If
Cells(intRow, 4).Value = ctl.Id
Err.Clear
intRow = intRow + 1
Next ctl
End If
Next cb
Range("A:B").EntireColumn.AutoFit
Application.StatusBar = False
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: ShowHelp
'''
''' Purpose: Shows user form with help
'''
''' Arguments: None
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 10 Jun 99 John Green Created
'''
Sub ShowHelp()
frmHelp.Show
End Sub
