Sub ListFirstLevelControls()
Dim cbCtl As CommandBarControl
Dim cbBar As CommandBar
Dim i As Integer
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"
Cells(1, 1).Resize(1, 4).Font.Bold = True
i = 2
For Each cbBar In CommandBars
Application.StatusBar = "Processing Bar " & cbBar.Name
Cells(i, 1).Value = cbBar.Name
i = i + 1
For Each cbCtl In cbBar.Controls
Cells(i, 2).Value = cbCtl.Caption
cbCtl.CopyFace
If Err.Number = 0 Then
ActiveSheet.Paste Cells(i, 3)
Cells(i, 3).Value = cbCtl.FaceId
End If
Cells(i, 4).Value = cbCtl.ID
Err.Clear
i = i + 1
Next cbCtl
Next cbBar
Range("A:B").EntireColumn.AutoFit
Application.StatusBar = False
End Sub
'------------------------------------------------------------
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"
End Function