Attribute VB_Name = "McRitchie_BarHopper_ws" '-- MODULE: 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 ' personal.xls!barhopping_ws.barhopper_ws ' menumaker.xls!auto_open ' personal.xls!barhopper_ws ' menumakr.xls!createmenu ' faceit.xla!buildbar ' personal.xls!gotosub ' personal.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 = "" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For Each cmdBarx In CommandBars barpost = barpost + 1 If Not cmdBarx.BuiltIn Or barpost = 1 Or _ InStr(1, cmdBarx.Name, "My", 1) Or InStr(1, cmdBarx.Name, "Tools", 1) Then ' Debug.Print "================" ' Debug.Print cmdBarx.Name ' Debug.Print "================" ActiveSheet.Cells(barqueue, 1).Value = 0 ActiveSheet.Cells(barqueue, 2) = cmdBarx.Name ActiveSheet.Cells(barqueue, 3) = cmdBarx.Index ActiveSheet.Cells(barqueue, 1).EntireRow.Font.ColorIndex = 23 ActiveSheet.Cells(barqueue, 1).EntireRow.Font.Bold = True ActiveSheet.Cells(barqueue, 4).Value = cmdBarx.Parent barqueue = barqueue + 1 BarHop_ws cmdBarx '<< Other Macro called HERE BarCap = "" End If 'Else ' ActiveSheet.Cells(barqueue, 2) = cmdBarx.Name ' barqueue = barqueue + 1 'End If Next cmdBarx Cells.EntireColumn.AutoFit MsgBox "done " & CommandBars.Count 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, "personal.xls'!", 1) ' If j = 0 Then j = InStr(1, ctl.OnAction, "personal.xls!", 1) ' If j > 0 Then aMacro = ctl.OnAction ' aMacro = "personal.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 Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub