指定時間が経過するとブックを強制終了するマクロ

背景

社内で複数名で使う共有ブックを誰かが使用中で保存できない問題の対策を考えた。

ブックの共同編集を許可する手もあるが、サーバ上のExcelファイルはスプシやTeams上と違って相手の操作状況がわからないため、データベース系ブックでキーの重複やデータの齟齬が発生する危険がある。

誰かが開きっぱなしで放置している場合はもうモラルで何とかするしかないと思われていたが、Application.OnTimeメソッドなる遅延実行メソッドがあることを知り、一瞬で解決した。

あとは編集中の一時ファイルを別ブックに保存するとかの味付けをするかしないかくらい。

設定方法と使用方法

編集可能時間をh,m,sで設定。
下記では3分。

3分経過するとmsgboxが表示され、10秒後に自動的に閉じる。

ここで「はい」を押すと再度3分の編集時間を与えられる。
このポップが出ている間に繰り返せば編集を続けられるが、放置されたら強制終了する。

標準モジュール

Option Explicit

Sub 指定時間経過で強制Close()
  Dim h, m, s
  h = 0
  m = 3
  s = 0
  
  Application.OnTime _
    Now + TimeSerial(h, m, s), _
    "'msg ""時間ですよ""'"
End Sub

Sub msg(ByVal strMsg As String)
  ThisWorkbook.Activate
  Beep
  If Judge(strMsg, 10) = False Then
    ThisWorkbook.Close
  Else
    Call 指定時間経過で強制Close
  End If
End Sub

Private Function Judge(Title, s) As Boolean
  Dim flg As Boolean
  Dim WSH As Object
  Set WSH = CreateObject("WScript.Shell")
  
  Dim prompt
  prompt = "制限時間になりました。" & vbLf & _
           "延長する場合は「はい」を押してください。" & vbLf & vbLf & _
            "※" & s & "秒後、自動的に閉じます。" & vbLf & _
            "その際、保存されていないデータは破棄されます。"

  Dim rc
  rc = WSH.Popup(prompt, s, Title, vbYesNo)
  If rc = vbYes Then
    flg = True
  Else
    flg = False
  End If
  Set WSH = Nothing
  
  Judge = flg
End Function

ThisWorkbookモジュール

Option Explicit

Private Sub Workbook_Open()
  Call 指定時間経過で強制Close
End Sub

参考

呼び出すプロシージャ名は"で囲むことになっており、
さらに'で囲み、半角スペースの後に""で引数を与えることもできるらしい。
（今回、無理に引数を使う必要はなかったがメモとして残しておいた。）

指定時間経過で強制Close

  Application.OnTime _
    Now + TimeSerial(h, m, s), _
    "'msg ""時間ですよ""'"

↓呼ぶプロシージャ

Sub msg(ByVal strMsg As String)