Excelの右クリックを拡張したり

Module1.bas

Const MENU_ENABLE_EXTENDMODE = "拡張メニューを追加"
Const MENU_DISABLE_EXTENDMODE = "拡張メニューを解除"

Const MENU_FILLGRAY = "選択範囲を灰色に"
Const MENU_FILLYELLOW = "選択範囲を黄色に"
Const MENU_FILLRED = "選択範囲を赤色に"
Const MENU_FILLCLEAR = "選択範囲の塗りつぶしを解除"

Const MENU_ADDALLLINE = "選択範囲に全て罫線"
Const MENU_CLEARLINE = "選択範囲の罫線をクリア"
Const MENU_CLEARINNERLINE = "選択範囲の内罫線をクリア"
Const MENU_SETREPORTLINE = "選択範囲の外側と縦を実線、横を点線"

Const MENU_COPYTOSHEET = "選択範囲をコピーして新規シート"
Const MENU_PASTEPLANEVALUE = "値を貼り付け"
Const MENU_PASTEFORMAT = "書式を貼り付け"

Const MENU_ENTERDIRECTION_DOWN = "Enter後下へ（標準）"
Const MENU_ENTERDIRECTION_RIGHT = "Enter後右へ"


Sub Auto_Open()
    Initialize

End Sub

Sub Auto_Close()
    Application.CommandBars("Cell").Reset
End Sub

Sub Initialize()
    Dim Menu
    
    ' 拡張メニューの追加
    Set Menu = Application.CommandBars("Cell").Controls.Add
    With Menu
        .Caption = MENU_ENABLE_EXTENDMODE
        .OnAction = "EnableExtendMenu"
        .BeginGroup = True
    End With
    
    ' Enter押下後の挙動追加
    Set Menu = Application.CommandBars("Cell").Controls.Add
    With Menu
        .Caption = MENU_ENTERDIRECTION_RIGHT
        .OnAction = "SetEnterAllowRight"
        .BeginGroup = False
    End With
    
    
End Sub

Sub SetEnterAllowRight()

    Application.MoveAfterReturnDirection = xlToRight
    Application.CommandBars("Cell").Reset
    Initialize
    
    Set Menu = Application.CommandBars("Cell").Controls.Add
    With Menu
        .Caption = MENU_ENTERDIRECTION_DOWN
        .OnAction = "SetEnterAllowDown"
        .BeginGroup = False
    End With
    

End Sub

Sub SetEnterAllowDown()

    Application.MoveAfterReturnDirection = xlDown
    Application.CommandBars("Cell").Reset
    Initialize
    
    Set Menu = Application.CommandBars("Cell").Controls.Add
    With Menu
        .Caption = MENU_ENTERDIRECTION_RIGHT
        .OnAction = "SetEnterAllowRight"
        .BeginGroup = False
    End With
    
End Sub


Sub EnableExtendMenu()

    Application.CommandBars("Cell").Reset
    DeleteDefaultMenu

    AddMenu

    Set Menu = Application.CommandBars("Cell").Controls.Add
    With Menu
        .Caption = MENU_DISABLE_EXTENDMODE
        .OnAction = "DisableExtendMenu"
        .BeginGroup = True
    End With

End Sub

Sub DisableExtendMenu()
    Application.CommandBars("Cell").Reset
    Initialize
End Sub

Sub DeleteDefaultMenu()
    Application.CommandBars("Cell").Controls("切り取り(&T)").Delete
    'Application.CommandBars("Cell").Controls("ｺﾋﾟー(&C)").Delete
    Application.CommandBars("Cell").Controls("貼り付け(&P)").Delete
    Application.CommandBars("Cell").Controls("形式を選択して貼り付け(&S)...").Delete
    Application.CommandBars("Cell").Controls("挿入(&I)...").Delete
    Application.CommandBars("Cell").Controls("削除(&D)...").Delete
    Application.CommandBars("Cell").Controls("数式と値のクリア(&N)").Delete
    Application.CommandBars("Cell").Controls("フィルタ(&E)").Delete
    Application.CommandBars("Cell").Controls("並べ替え(&O)").Delete
    Application.CommandBars("Cell").Controls("コメントの挿入(&M)").Delete
    'Application.CommandBars("Cell").Controls("ドロップダウン リストから選択(&K)").Delete
    Application.CommandBars("Cell").Controls("ふりがなの表示(&S)").Delete
    Application.CommandBars("Cell").Controls("範囲に名前を付ける(&R)...").Delete
    Application.CommandBars("Cell").Controls("ハイパーリンク(&H)...").Delete
End Sub
Sub AddMenu()

    ' Set Newb = Application.CommandBars("Cell").Controls.Add(Before:=1)


    Dim Newb
    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = MENU_FILLGRAY
        .OnAction = "FillColorGray"
        .BeginGroup = False
    End With
    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = MENU_FILLYELLOW
        .OnAction = "FillColorYellow"
        .BeginGroup = False
    End With
    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = MENU_FILLRED
        .OnAction = "FillColorRed"
        .BeginGroup = False
    End With
    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = MENU_FILLCLEAR
        .OnAction = "ClearColor"
        .BeginGroup = False
    End With

    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = MENU_ADDALLLINE
        .OnAction = "AddAllLine"
        .BeginGroup = True
    End With

    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = MENU_CLEARLINE
        .OnAction = "ClearLine"
        .BeginGroup = False
    End With

    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = MENU_CLEARINNERLINE
        .OnAction = "ClearInsideLine"
        .BeginGroup = False
    End With

    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = MENU_SETREPORTLINE
        .OnAction = "SetReportLine"
        .BeginGroup = False
    End With


    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = MENU_COPYTOSHEET
        .OnAction = "CopyToNewSheet"
        .BeginGroup = True
    End With

    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = MENU_PASTEPLANEVALUE
        .OnAction = "PastePlaneValue"
        .BeginGroup = False
    End With

    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = MENU_PASTEFORMAT
        .OnAction = "PasteFormat"
        .BeginGroup = False
    End With

End Sub


Sub DelMenu()
    Application.CommandBars("Cell").Reset



'    Application.CommandBars("Cell").Controls(MENU_FILLGRAY).Delete
'    Application.CommandBars("Cell").Controls(MENU_FILLYELLOW).Delete
'    Application.CommandBars("Cell").Controls(MENU_FILLRED).Delete
'    Application.CommandBars("Cell").Controls(MENU_FILLCLEAR).Delete
'    Application.CommandBars("Cell").Controls(MENU_CLEARINNERLINE).Delete

    
End Sub



Sub FillColorGray()
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With

End Sub

Sub FillColorYellow()
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

End Sub

Sub FillColorRed()
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

End Sub

Sub ClearColor()
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

End Sub

Sub ClearInsideLine()
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub

Sub AddAllLine()
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With

End Sub

Sub ClearLine()
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub

Sub SetReportLine()
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlDot
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With

End Sub

Sub CopyToNewSheet()
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

End Sub

Sub PastePlaneValue()
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub

Sub PasteFormat()
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
End Sub