VBA 右クリックメニュー追加、サブメニュー有り Excel2000 VBA

VBA 右クリックメニュー追加、サブメニュー有り

PERSONAL.XLSなどxlStartフォルダないのxlsファイルの標準モジュールに記述
　Excelを起動すると、auto_openでマクロ（右クリックメニューサブ有り2）を読み込み右クリックメニューを設定する

Sub Auto_Open()
call 右クリックメニューサブ有り2
End Sub

Sub 右クリックメニューサブ有り2()
'
'参考サイト　http://www.seiji-tsubosaki.net/ExcelTech/ExcelProfessionalEngineerTechnic/Contents_03.htm
'

' 右クリックメニューを初期設定に戻す(このマクロで設定したメニューを削除）
    Application.CommandBars("Cell").Reset
'------  右クリックメニューを設定 ------
    '右クリックサブメニュー無し
      With Application.CommandBars("cell").Controls.Add()
      .Caption = "書式の貼り付け"
      .OnAction = "書式の貼り付け"
      .BeginGroup = True
      End With
      With Application.CommandBars("cell").Controls.Add()
      .Caption = "罫線を除く全ての貼り付け"
      .OnAction = "罫線を除く全て貼り付け"
      .BeginGroup = False
      End With
      With Application.CommandBars("cell").Controls.Add()
      .Caption = "数式の貼り付け"
      .OnAction = "数式の貼り付け"
      .BeginGroup = False
      End With
      With Application.CommandBars("cell").Controls.Add()
      .Caption = "リンク貼り付け (&L)"
      .OnAction = "リンク貼り付け"
      .BeginGroup = False
      End With
      With Application.CommandBars("cell").Controls.Add()
      .Caption = "自動セル幅"
      .OnAction = "自動セル幅"
      .BeginGroup = False
      End With
       With Application.CommandBars("cell").Controls.Add()
      .Caption = "条件付き書式の削除"
      .OnAction = "条件付き書式の削除"
      .BeginGroup = False
      End With
    ' 右クリックメニューサブメニューあり
    With Application.CommandBars("Cell") _
        .Controls.Add(Type:=msoControlPopup)
        .BeginGroup = True                     '区切り線
        .Caption = "シートツール"                     '追加項目
        With .Controls.Add(Type:=msoControlButton)    'サブ項目１
            .Caption = "数式保護"           'サブ項目１表示名
            '.FaceId = 8                            'アイコン番号
            .OnAction = "シートの数式を選択出来ないようにする"                '実行するマクロ
        End With
          With .Controls.Add(Type:=msoControlButton)    'サブ項目２
              .Caption = "シートイベント有効無効"                'サブ項目２表示名
              '.FaceId = 167                             'アイコン番号
              .OnAction = "シートイベント有効無効"                '実行するマクロ
          End With
         
      End With

  End Sub
 

---

登録するマクロ例

 Sub 自動セル幅()
'列幅を自動調整
ActiveSheet.Select
Range("A:IV").Columns.AutoFit
End Sub
Sub 条件付き書式の削除()
'
'選択範囲の条件付き書式を削除する
'
'
Dim syori As String

syori = MsgBox("選択範囲の条件付き書式を削除するには「はい」を" & vbCrLf & vbCrLf & "キャンセルするには「いいえ」を押してください", vbYesNo, "条件付き書式の削除")
Select Case syori
    Case vbYes
    Selection.FormatConditions.Delete
    Case vbNo
    Exit Sub
End Select

End Sub
Sub 罫線を除く全て貼り付け()
    Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
End Sub
Sub 書式の貼り付け()
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
End Sub
Sub 数式の貼り付け()
    Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
End Sub
Sub リンク貼り付け()
    ActiveSheet.Paste Link:=True
End Sub
Sub シートイベント有効無効()
'実行する度に有効→無効→有効
Select Case Application.EnableEvents
    Case True
        Application.EnableEvents = False
        Application.StatusBar = "シートイベント無効"
    Case False
        Application.EnableEvents = True
        Application.StatusBar = "シートイベント有効"
End Select
End Sub
Sub シートの数式を選択出来ないようにする()
'「シートイベントで数式の有るセルを選択したら右に移動する」、
'コードをシートモジュールにに追記する
On Error GoTo owari
  Dim W_Book  As Workbook
  Dim book_name, sheet_name, myProcName As String
  Dim i, end_line As Long
'アクティブブック名シート名取得（モジュールを追加する）
    book_name = ActiveWorkbook.Name
    sheet_name = ActiveSheet.Name
'book set
    Set W_Book = Workbooks(book_name)
  
'書き込むプロシージャ名と同じ名があるかチェック
 
    myProcName = "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
  
    With W_Book.VBProject.VBComponents.Item(sheet_name).CodeModule
        'end_line = .CountOfLines
        For i = 1 To .CountOfLines
        'Debug.Print .Lines(i, 1)
            If myProcName = .Lines(i, 1) Then GoTo owari
            'Debug.Print .Lines(i, 1) '1行ずつコード
        Next i
    End With
  
'挿入書き込み
  With W_Book.VBProject.VBComponents.Item(sheet_name).CodeModule
          .insertlines 2, "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
          .insertlines 3, "If Target.HasFormula = True Then ActiveCell.Offset(0, 1).Select"
          .insertlines 4, "End Sub"
  End With
  Set W_Book = Nothing
  MsgBox "シートの数式保護（選択不可）完了"
  Exit Sub
owari:
    Set W_Book = Nothing
    MsgBox "既にプロシージャが存在します。"
End Sub

.