WorkGroupBlocker - 作業グループ禁止アドイン

AppMain.bas

Rem
Rem 作業グループ禁止アドイン メインモジュール
Rem
Rem 2020/02/18 : 初回版
Rem 2020/02/27 : Gist公開用調整
Rem
Rem @KotorinChunChun
Rem
Option Explicit
Option Private Module

Public Const APP_NAME = "作業グループ禁止アドイン"
Public Const APP_CREATER = "@KotorinChunChun"
Public Const APP_VERSION = "0.11"
Public Const APP_UPDATE = "2020/02/27"
Public Const APP_URL = "https://www.excel-chunchun.com/entry/work_group_blocker"

Public instBlockMultiSelectSheet As BlockMultiSelectSheet

'--------------------------------------------------
'アドイン実行時
Sub AddinStart()
    MsgBox "あなたの身を【作業グループ】から完全に護ります！！！" & vbLf & _
             vbLf & _
            "複数のシートを選びっぱなしにする" & vbLf & _
            "【作業グループ】は絶対に許しません！！！", _
                vbInformation + vbOKOnly, APP_NAME
    Call MonitorStart
End Sub

'アドイン一時停止時
Sub AddinStop()
    Dim item
    For Each item In Array( _
        "え～作業グループ許可しちゃうの～？", _
        "作業グループって複数シート選択のことだよ", _
        "複数シート選択したまま作業すると、データ壊しちゃうかもよ？", _
        "複数シート選択したまま保存すると、次に使う人がデータ壊しちゃうかもよ？", _
        "それでも作業グループ使いたいの？")
        If MsgBox(item, vbExclamation + vbYesNo, APP_NAME) = vbNo Then
            MsgBox "だよね～作業グループなんていらないよね～", vbOKOnly, APP_NAME
            Exit Sub
        End If
    Next
    MsgBox "もぉどうなっても知らないんだからっ！！！", vbOKOnly, APP_NAME
    Call MonitorStop
End Sub

'アドイン設定表示
Sub AddinConfig(): Call SettingFOrm.Show: End Sub

'アドイン情報表示
Sub AddinInfo()
    Select Case MsgBox(ThisWorkbook.Name & vbLf & vbLf & _
            "バージョン : " & APP_VERSION & vbLf & _
            "更新日　　 : " & APP_UPDATE & vbLf & _
            "開発者　　 : " & APP_CREATER & vbLf & _
            "実行パス　 : " & ThisWorkbook.Path & vbLf & _
            "公開ページ : " & APP_URL & vbLf & _
            vbLf & _
            "使い方や最新版を探しに公開ページを開きますか？" & _
            "", vbInformation + vbYesNo, "バージョン情報")
        Case vbNo
            '
        Case vbYes
            CreateObject("Wscript.Shell").Run APP_URL, 3
    End Select
End Sub

'アドイン完全終了
Sub AddinEnd(): ThisWorkbook.Close False: End Sub
'--------------------------------------------------

'監視開始
'Workbook_Openから呼ばれる
Sub MonitorStart(): Set instBlockMultiSelectSheet = New BlockMultiSelectSheet: End Sub

'監視停止
Sub MonitorStop(): Set instBlockMultiSelectSheet = Nothing: End Sub

BlockMultiSelectSheet.cls

Rem
Rem 複数シート選択をした状態での操作を禁止する
Rem ・上書き保存しようとしたブックは解除してから保存させる
Rem ・新たに開いたブックなら真っ先に解除させる
Rem ・セルの編集なら取り消しを案内する
Rem
Rem　　インスタンスを生成するだけで監視します。
Rem
Rem @KotorinChunChun
Rem
Rem 2020/02/18
Rem
Option Explicit

Public WithEvents app As Application

Private Sub app_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If ActiveWindow Is Nothing Then Exit Sub
    If ActiveWindow.SelectedSheets.Count = 1 Then Exit Sub
    
    'いいえを選択した場合は2度目以降の実行は行わない。
    Static MultiSelectedCounter As Long
    If MultiSelectedCounter > 0 Then MultiSelectedCounter = MultiSelectedCounter - 1: Exit Sub
    
    Debug.Print Sh.Name, Target.Address
    Select Case MsgBox("複数のシートが選択されたまま編集されようとしています。" & vbLf & _
                        "安全のため解除しませんか？" & vbLf & _
                        vbLf & _
                        "　　　はい：編集を取り消して単一シートを選択" & vbLf & _
                        "　　いいえ：無視してデータを書き込む", _
                        vbYesNoCancel, APP_NAME)
        Case vbYes
            ActiveWindow.SelectedSheets(1).Select
            'シートごとにこのイベントは呼ばれるが、最初の1回でUndoするともう呼ばれない。
            Application.Undo
        Case vbNo
            'いいえの場合、選択されたシートの数分Changeイベントが起こるのでその分だけイベントを取り消す
            If MultiSelectedCounter = 0 Then MultiSelectedCounter = ActiveWindow.SelectedSheets.Count - 1
    End Select
End Sub

Private Sub app_WorkbookBeforeSave(ByVal wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Call 作業グループ禁止
End Sub

Private Sub app_WorkbookOpen(ByVal wb As Workbook)
    Call 作業グループ禁止
End Sub

Sub 作業グループ禁止()
    If ActiveWindow Is Nothing Then Exit Sub
    If ActiveWindow.SelectedSheets.Count = 1 Then Exit Sub
    
    '保存と開くでは黙って解除しても良いと思う
    
    Select Case MsgBox("複数のシートが選択されています。" & vbLf & _
                        "安全のため解除しませんか？" & vbLf & _
                        vbLf & _
                        "　　　はい：解除する" & vbLf & _
                        "　　いいえ：解除しない" & vbLf & _
                        vbYesNoCancel, APP_NAME)
        Case vbYes: ActiveWindow.SelectedSheets(1).Select
        Case Else:  'vbNo = 何もしない。
    End Select
End Sub

'----------------------------------------
'コンストラクタ
Private Sub Class_Initialize()
    Set app = Application
End Sub

CustomUI.bas

Rem
Rem CustomUI
Rem
Rem 本モジュールは自作のCustomUIエディタから自動生成したイベントハンドラです。
Rem

Sub onAction_AddinStart(control As IRibbonControl): Call AddinStart: FinalUseCommand = "AddinStart": End Sub
Sub onAction_AddinStop(control As IRibbonControl): Call AddinStop: FinalUseCommand = "AddinStop": End Sub
Sub onAction_AddinConfig(control As IRibbonControl): Call AddinConfig: FinalUseCommand = "AddinConfig": End Sub
Sub onAction_AddinInfo(control As IRibbonControl): Call AddinInfo: FinalUseCommand = "AddinInfo": End Sub
Sub onAction_AddinEnd(control As IRibbonControl): Call AddinEnd: FinalUseCommand = "AddinEnd": End Sub

SettingForm.frm

'未完成のため空