【Excel VBA】セル上の右クリックのメニューに、機能を追加してみた

＜はじめに＞

Excelをよく使う職場なのですが、

・エクスプローラーでサーバー上のExcel開いて、邪魔だからエクスプローラー閉じたけど
あれ？どこの場所のエクセル開いてるんだっけ？とか

・フルパスの確認とか、コピーを「ファイル＞情報」から出来るけど、開くの手間だなーとか

・帳票を見ていて、ちょっと計算があっているか、直ぐに電卓起動したいなーとか

とか色々、思うところがあり

エクセル上から、色々ショートカットできないものかと

ただ、クイック アクセス ツールバーには、もう追加したくない❗
（もう半分くらい占領されているから）

リボンでもいいけど、なんかスマートじゃない・・・

色々調べていたら、セル上の右クリックのメニューに独自機能を追加できるとのこと。

＞やりたいこと・・

▼とりあえず、右クリックのメニューに以下を追加してみたい
ファイル情報
├　ファイルパス表示
├　ファイルの保存場所を開く
└　フルパスをコピー

アプリ起動
├　電卓
└　エクスプローラー

▼どのブックでも使いたいので、個人ブックのマクロにて実施する

＜やってみた＞

標準モジュールに記載
▼メニューを作る部分

[メニュー定義]sub

Sub AddMenu()

    '独自コマンドをリセット
    CommandBars("Cell").Reset
    
    '変数定義
    Dim Newbar As CommandBarControl
    Dim getFileInfo1, getFileInfo2, getFileInfo3 As CommandBarControl
    Dim appMacro1, appMacro2 As CommandBarControl
   
    ' [ファイル情報]
    Set Newbar = CommandBars("Cell").Controls.Add(Type:=msoControlPopup, before:=1)
    With Newbar
        .Caption = "ファイル情報" ' 右クリックの表示名
        .OnAction = "fileInfo" ' 呼び出すSub名
        Set getFileInfo1 = .Controls.Add ' [1] フルパス表示
        Set getFileInfo2 = .Controls.Add ' [2] ファイルの場所を開く
        Set getFileInfo3 = .Controls.Add ' [3] フルパスをコピー
    End With

    ' [アプリ起動]
    Set Newbar = CommandBars("Cell").Controls.Add(Type:=msoControlPopup, before:=2)
    With Newbar
        .Caption = "アプリ起動" ' 右クリックの表示名
        .OnAction = "appExec" ' 呼び出すSub名
        Set appMacro1 = .Controls.Add ' [1] 電卓
        Set appMacro2 = .Controls.Add ' [1] エクスプローラー
    End With
    
    ' 右クリックメニュー項目の「切り取り」の上に区切り線を入れる
    ' 増減させたらControlsの数をずらす必要あり
    CommandBars("Cell").Controls(3).BeginGroup = True
    
End Sub

[メニュー定義＞ファイル情報]sub

Sub fileInfo()
    
    With CommandBars("Cell").Controls("ファイル情報")
    
        ' [1] フルパス表示
        .Controls(1).Caption = ActiveWorkbook.FullName
        .Controls(1).FaceId = 39
        
        ' [2] ファイルの場所を開く
        .Controls(2).Caption = "ファイルの場所を開く"
        .Controls(2).OnAction = "openExplorer"
        .Controls(2).FaceId = 23
        .Controls(2).TooltipText = "エクスプローラーにて、ファイルの場所を開きます"
        
        ' [3] フルパスをコピー
        .Controls(3).Caption = "フルパスをコピー"
        .Controls(3).OnAction = "pathCopy"
        .Controls(3).FaceId = 19
        .Controls(3).TooltipText = "クリップボードにファイルのフルパスをコピーします"
    End With

End Sub

[メニュー定義＞アプリ起動]sub

Sub appExec()
    
    With CommandBars("Cell").Controls("アプリ起動")
        '[1] 電卓
        .Controls(1).Caption = "電卓"
        .Controls(1).OnAction = "execCalc"
        .Controls(1).FaceId = 283
        .Controls(1).TooltipText = "電卓を起動します"
        
        '[2] エクスプローラー
        .Controls(2).Caption = "エクスプローラー"
        .Controls(2).OnAction = "execExplr"
        .Controls(2).FaceId = 32
        .Controls(2).TooltipText = "エクスプローラーを起動します"
        
    End With

End Sub

▼処理部分（OnAction部分）

[ファイル情報]処理sub

Sub openExplorer()
    ' [2] ファイルの場所を開く
    Shell "explorer.exe " & ActiveWorkbook.path, vbNormalFocus

End Sub

Sub pathCopy()
    ' [3] フルパスをコピー
    ' テキストボックス作成してコピーする
    Dim objTxt As Object
    Set objTxt = CreateObject("Forms.TextBox.1")
    With objTxt
        .MultiLine = True
        .Text = ActiveWorkbook.FullName
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
    End With
    Set objTxt = Nothing

End Sub

[アプリ起動]処理sub

Sub execCalc()
    '[1] 電卓
    Shell "calc.exe", vbNormalFocus
    
End Sub

Sub execExplr()
    '[2] エクスプローラー
    Shell "explorer.exe", vbNormalFocus

End Sub

＜出来上がり＞

AddMenuを実行するとメニューが追加される。

▼右クリックしたときのメニュー
(上の方に、ファイル情報とアプリ起動がメニューに追加されている)

▼ファイル情報

※ シェアポだと「https://[XXXXX].sharepoint.com/site/～/[XXXXX].xlsx」のような、URLで表示され、「ファイルの場所を開く」をするとedgeで開く。

▼アプリ起動
（各々、起動する）

(´・x・).oO◯（ なにげに便利なのでは・・

（Microsoft Excel2021 と Microsoft365 v2308で動きました）

※ 改ページプレビュー状態だと、右クリックが標準に戻ってしまうので注意。

＜おわりに＞

・以外と色々追加できそうだなぁ。
・FaceId を探すのが面倒だった。
・beforeを外すと、メニューの下に追加される。

Set Newbar = CommandBars("Cell").Controls.Add(Type:=msoControlPopup, before:=1)
↓
Set Newbar = CommandBars("Cell").Controls.Add(Type:=msoControlPopup)

＜参考＞

以下を参考にさせて頂きました。ありがとうございます。

▼右クリックメニュー
（OnActionに引数付きで呼び出すやり方も載ってました）

▼FaceId を探すのに