Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
WorkGroupBlocker - 作業グループ禁止アドイン
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
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
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
'未完成のため空
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.