Attribute VB_Name = "McRitchie_BarHopper_ws"
'-- http://www.mvps.org/dmcritchie/excel/barhopper.htm
'--  this code is the worksheet version of what i seen in the above HTML
'-- http://www.mvps.org/dmcritchie/excel/code/barhopper_ws.txt
'-- David McRitchie
Option Explicit
Dim barqueue  As Long
Dim barpost   As Long
Dim BarCap    As String
Dim barCaptain As String
'   David McRitchie,  not published on site or newsgroup 2003-08-06
'   pesonal.xls!barhopping_ws.barhopper_ws
'   menumaker.xls!auto_open
'   pesonal.xls!barhopper_ws
'   menumakr.xls!createmenu
'   faceit.xla!buildbar
'   pesonal.xls!gotosub
'   pesonal.xls!lookat
Sub lookat()
   Application.Goto Reference:="personal.xls#barhopping_ws!lookat"
End Sub
Sub BarHopper_ws()
  If Left(LCase(ActiveSheet.Name), 10) = "menus_2003" Then ActiveSheet.Delete
  'Create New Sheet
    Sheets.Add after:=ActiveSheet
  'Rename current Sheet
    ActiveSheet.Name = "MenuS_" _
      & Format(Now, "yyyymmdd-hhmms")
  Range("A1").Value = "Lvl"
  Range("B1").Value = "Caption"
  Range("C1").Value = "Macro or level-zero menu placement"
  Range("D1").Value = "Divider"
  Range("E1").Value = "FaceID"
  Range("G1").Value = "created for MenuMaker is J-Walkenbach's Tip53"
  Dim cmdBarx As CommandBar
  Dim i As Long
  barqueue = 2   'first row
  barpost = 0
  barCaptain = ""
  For Each cmdBarx In CommandBars
    barpost = barpost + 1
    If Not cmdBarx.BuiltIn Then
      If InStr(1, cmdBarx.Name, "My") Or InStr(1, cmdBarx.Name, "Toolbar") Then
       Debug.Print "================"
       Debug.Print cmdBarx.Name
       Debug.Print "================"
       ActiveSheet.Cells(barqueue, 1).Value = 0
       ActiveSheet.Cells(barqueue, 2) = cmdBarx.Name
       ActiveSheet.Cells(barqueue, 1).EntireRow.Font.ColorIndex = 23
       ActiveSheet.Cells(barqueue, 1).EntireRow.Font.Bold = True
       barqueue = barqueue + 1
       BarHop_ws cmdBarx
       BarCap = ""
      End If
    Else
     ' ActiveSheet.Cells(barqueue, 2) = cmdBarx.Name
     ' barqueue = barqueue + 1
    End If
  Next cmdBarx
    Cells.EntireColumn.AutoFit
End Sub
Sub BarHop_ws(cmdBar As CommandBar, Optional iteration As Variant)
  '--CommandBarControls Collection
  '--http://www.cit.ctu.edu.vn/daotao/Book/ACCESS97/COURSE/MOD04-11.HTM
  '--After replacements (even if they are same as before, are not
  '-- effective until Excel has been completely recycled.
  '-- are not useable until Excel has been recycled, for toolbars to be savedook themre' Debug.Print String$(iteration * 5 + 2, " "); "->"; ctl.OnAction
          
  Dim ctl As CommandBarControl
  Dim aMacro As String
  Dim j As Long
  If IsMissing(iteration) Then iteration = 0
  For Each ctl In cmdBar.Controls
    Debug.Print String$(iteration * 5, " "); ctl.Caption
    BarCap = ctl.Caption
    'Menus with a control type of msoControlPopup will
    'have sub menus that you will run through
    If ctl.Type = msoControlPopup Then
       'If it has a sub-menu, call your routine recursively,
       'passing the command bar object for that control

       ActiveSheet.Cells(barqueue, 1).Value = iteration + 1
       ActiveSheet.Cells(barqueue, 2) = BarCap
       ActiveSheet.Cells(barqueue, 3) = BarCap
       If ctl.BeginGroup Then _
          ActiveSheet.Cells(barqueue, 4) = ctl.BeginGroup
       ActiveSheet.Cells(barqueue, 7) = BarCap
       ActiveSheet.Cells(barqueue, 1).EntireRow.Font.ColorIndex = 3
       ActiveSheet.Cells(barqueue, 7) = BarCap
 
       barCaptain = BarCap
       barqueue = barqueue + 1   'prepare to populate the next rwo
       BarHop_ws ctl.CommandBar, iteration + 1  'Reentrant coding
    Else
      'REENTRY --- of macros on buttons and menus
      j = InStr(1, ctl.OnAction, "pesonal.xls'!", 1)
      If j = 0 Then j = InStr(1, ctl.OnAction, "pesonal.xls!", 1)
     ' If j > 0 Then
           aMacro = "pesonal.xls!" & Mid(ctl.OnAction, j + 13)
           Debug.Print String$(iteration * 5 + 2, " "); "--"; aMacro
          ' ctl.OnAction = aMacro
          ' Debug.Print String$(iteration * 5 + 2, " "); "->"; ctl.OnAction
          ActiveSheet.Cells(barqueue, 1) = iteration + 1
          ActiveSheet.Cells(barqueue, 2) = BarCap
          ActiveSheet.Cells(barqueue, 3) = aMacro
          If ctl.BeginGroup Then _
            ActiveSheet.Cells(barqueue, 4) = ctl.BeginGroup
          ActiveSheet.Cells(barqueue, 5) = ctl.ID
          Select Case ctl.ID      ' Evaluate Number.
            Case 2949
             ActiveSheet.Cells(barqueue, 5).Font.ColorIndex = 48
             ActiveSheet.Cells(barqueue, 5).Value = ""
            Case Else
             ActiveSheet.Cells(barqueue, 5).Font.Bold = True
          End Select
          ActiveSheet.Cells(barqueue, 7) = barCaptain
          barqueue = barqueue + 1
     ' End If
    End If
  Next ctl
End Sub