Teams等で不在にしないための魔法(居留守ツール)
2つマクロコードをVBE画面に貼り付け後、すぐに使用できます。
テスト後、自己責任にてご利用ください.(Microsoft365 64bit環境推奨)
- 新規のExcelブックを作成します。
- 【ページレイアウト】タブ⇒【テーマ】⇒【フォント】
【フォントのカスタマイズ】で 下の2つ、
日本語(見出し、本文)を ”Meiryo UI”に設定します。 - 【Alt】+【F11】キーを押下し、VBE画面を出します。
- 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成します。
- 下記ボックス内をコピーし、標準モジュールに貼り付けます。
- モジュール名を【A01_Public】に変更します。
モジュール名:A01_Public
Option Explicit Public Bln_Err As Boolean Public ErrProsName As String Public wb As Workbook Public wsMain As Worksheet Public wsCtrl As Worksheet Sub SetObject() Set wb = ThisWorkbook Set wsMain = wb.Worksheets("Main") End Sub Sub ReSetObject() Set wb = Nothing Set wsMain = Nothing End Sub '***************************************************** ' 画面制御セット '***************************************************** Public Sub StopUpdating() With Application .ScreenUpdating = False '画面描画停止 .EnableEvents = False 'イベント動作停止 .EnableCancelKey = xlInterrupt '[Esc]キーでエラーをトラップする '========================= '.EnableCancelKey = xlErrorHandler '[Esc]キーでエラーをトラップする ' .EnableCancelKey = xlDisabled '[Esc]キーでの中断を無視する '========================= '.Cursor = xlWait .DisplayAlerts = False '警告非表示 .DisplayStatusBar = True 'ステータスバーを表示 End With End Sub '***************************************************** ' 画面制御セット '***************************************************** Public Sub Updating() With Application .ScreenUpdating = True '画面描画再開 .EnableEvents = True 'イベント動作再開 .Cursor = xlDefault .DisplayAlerts = True '警告再表示 .StatusBar = "" 'ステータスバーを表示 End With End Sub '----------------------------------------------------- ' ステータスバーの使用 '----------------------------------------------------- Public Sub showStatus(ByVal msg As String) 'エラーを無視 On Error Resume Next Application.StatusBar = msg 'エラー制御を戻す On Error GoTo 0 End Sub '----------------------------------------------------- ' ステータスバー表示をクリア '----------------------------------------------------- Public Sub ClearStatus() 'エラーを無視 On Error Resume Next Application.StatusBar = False 'エラー制御を戻す On Error GoTo 0 End Sub '----------------------------------------------------- ' OSに制御を渡す ' 【esc】キーで止まらないので、使用中止 '----------------------------------------------------- Public Sub exeBreak() 'エラーを無視 On Error Resume Next DoEvents 'エラー制御を戻す On Error GoTo 0 End Sub '+++***********************************************+++ ' シート検出 ' Call IsShtOwb(shtName, wbName ) '+++***********************************************+++ Public Function IsShtOwb(shtName As String, wbName As String) As Boolean Dim sht As Worksheet Dim Owb As Workbook IsShtOwb = False Set Owb = Workbooks(wbName) For Each sht In Owb.Worksheets If sht.Name = shtName Then IsShtOwb = True Set Owb = Nothing Exit Function End If Next sht 'エラーを無視 On Error Resume Next Set Owb = Nothing 'エラー制御を戻す On Error GoTo 0 End Function ' +++*******************************************************+++ ' アクティブシートのシェイプを全削除 ' +++*******************************************************+++ Public Sub delShapes() Dim shp As Shape For Each shp In ActiveSheet.Shapes shp.Delete Next End Sub
コメント