G-Tool1-A01_逆・居留守ツール用

Excel VBA

Teams等で不在にしないための魔法(居留守ツール)
2つマクロコードをVBE画面に貼り付け後、すぐに使用できます。
テスト後、自己責任にてご利用ください.(Microsoft365 64bit環境推奨)

  1. 新規のExcelブックを作成します。
  2. 【ページレイアウト】タブ⇒【テーマ】⇒【フォント】
    【フォントのカスタマイズ】で 下の2つ、

    日本語(見出し、本文)を ”Meiryo UI”に設定します。
  3. 【Alt】+【F11】キーを押下し、VBE画面を出します。
  4. 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成します。
  5. 下記ボックス内をコピーし、標準モジュールに貼り付けます。
  6. モジュール名を【A01_Public】に変更します。

 G-Tool1-M01 につづく

 モジュール名: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

コメント

タイトルとURLをコピーしました