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

Excel VBA

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

 G-Tool1-A01 からのつづき

  1. 【Alt】+【F11】キーを押下し、VBE画面を出します。
  2. 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成します。
  3. 下記ボックス内をコピーし、標準モジュールに貼り付けます。
  4. モジュール名を【M01_Main】に変更します。
  5. 名前を付けて保存で、ファイル名:【お役立ちツール】
  6. ファイル形式:【Excelマクロ有効ブック :拡張子(.xlsm)】で保存します。
  7. 下記【M01_Main】の 22行目【Sub setSht】プロシージャ内でポイントし(1度クリックして)、キーボードの【F5】キーを押下します。
    すると、【Main】シートが作成されます

使用方法

【Main】シートが作成できたでしょうか。
セル C7で設定時間を選択し、【実行】ボタンを押下で利用できます。
※ 使用中は他のExcelは閉じて短い時間でお試し後、ご利用ください

 モジュール名:M01_Main
Option Explicit

'***************************************************************
'  【使用方法】
' ファイルのフォントテーマを"Meiryo UI"に変更してください。

' 2つのモジュールをコピー後、
' ① 下記【setSht】のコード内で1度クリックし、
'   【F5】キーを押下
'   ⇒【Main】シートが作成される
'
' ② 【Main】シートの セルC7 で時間を指定後、
'   【実行】ボタンを押下
' ※ 念のため、他のExcel等は閉じ、短い時間を指定して
'  テスト実行後、本番使用してください。
' 【esc】キーの長押しで、中断できます。
'  ↑メッセージボックスが出現するまで最大10秒間長押しする
'***************************************************************
'====================================================
'   【Main】シートを設定する
'====================================================
Sub setSht()
    'ここをポイントし、【F5】キーを押下
    Dim MaxRow As Long        '最終行
    Dim MaxCol As Long        '最終列
    Dim myShp As Shape
    Dim nmlTmn As Boolean
    Dim myC As Range
    Dim wbName As String
    Dim MainSht As Worksheet
    Dim IsBlank As Boolean
    Const shtName As String = "Main"
    
    Bln_Err = False
    ErrProsName = "setShtErr"
    
    On Error GoTo setSht_Err
    Call showStatus("シート設定中")
    
    wbName = ActiveWorkbook.Name
'******************************************************************************
    '日本語 フォントテーマをMeiryo UIで設定
    With ActiveWorkbook.Theme.ThemeFontScheme
        .MajorFont.Item(3).Name = "Meiryo UI"      '見出しのフォント
        .MinorFont.Item(3).Name = "Meiryo UI"      '本文のフォント
    End With
'******************************************************************************
  
    IsBlank = False
    If IsShtOwb(shtName, wbName) = False Then
        With Worksheets(1)
            With .UsedRange
                MaxRow = .Rows(.Rows.Count).Row
                MaxCol = .Columns(.Columns.Count).Column
            End With
        End With
        If MaxRow = 1 And MaxCol = 1 Then
            IsBlank = True
        End If
        If IsBlank Then
            Worksheets(1).Name = shtName
        Else
            ActiveWorkbook.Worksheets.Add Before:=Worksheets(1)
            ActiveSheet.Name = shtName
        End If
    Else
        With ActiveWorkbook.Worksheets(shtName)
            .Select
            .Cells.Clear
        End With
        Call delShapes
    End If
'=====================================================
    Call StopUpdating
    Call SetObject
'=====================================================
   
   'シート設定処理
    With wsMain
        .Range("1:12").RowHeight = 5
        .Rows(2).RowHeight = 40
        .Rows(5).RowHeight = 20
        .Rows(7).RowHeight = 32
        .Rows(9).RowHeight = 20
        .Rows(10).RowHeight = 32
        .Columns("A:I").ColumnWidth = 0.5
        .Columns("C").ColumnWidth = 16.4
        .Columns("E").ColumnWidth = 16.4
        .Columns("G").ColumnWidth = 16.4
        .Cells.Font.Name = "MeiryoUI"
        .Cells(2, 2) = "お役立ちツール I’m here."
        .Cells(2, 2).Font.Size = 16
        .Cells(2, 2).Font.Color = RGB(255, 255, 255)
        .Cells(5, 3) = "設定時間"
        .Cells(9, 3) = "Start"
        .Cells(5, 5) = "中断したいときは【Esc】キーを5秒くらい長押し"
        .Cells(9, 5) = "End"
        .Range("B2:H2").Merge
        .Range("B2:H2").Interior.Color = RGB(0, 112, 192)
        .Range("B2").HorizontalAlignment = xlCenter

        With .Range("B4:H12")
            .Interior.Color = RGB(238, 242, 247)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        .Range("E5").HorizontalAlignment = xlLeft
        .Range("C7").Interior.Color = xlNone         '背景色無色
        .Range("E7").Interior.Color = xlNone         '背景色無色
        .Range("C10").Interior.Color = xlNone        '背景色無色
        .Range("E10").Interior.Color = xlNone        '背景色無色
        .Range("G10").Interior.Color = xlNone        '背景色無色
        .Range("C5:E5").Font.Color = RGB(0, 112, 192)
        .Range("C9:E9").Font.Color = RGB(0, 112, 192)
        With .Range("C7")
            .NumberFormatLocal = "#"" 分"""
            With .Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:="1,3,5,10,15,30,45,60,90"
            End With
        End With
        Set myC = .Range("G7")
        Set myShp = .Shapes.AddShape _
              (msoShapeRoundedRectangle, myC.Left, myC.Top, myC.Width, myC.Height)
        Set myC = Nothing
        With myShp
            With .Fill
                .ForeColor.RGB = RGB(0, 112, 192)
            End With
            With .Line
                .Weight = 0.5
                .ForeColor.RGB = RGB(0, 112, 192)
            End With
            With .TextFrame.Characters
                .Text = "実  行"
                .Font.Size = 12
                .Font.Color = RGB(255, 255, 255)
            End With
            With .TextFrame
                .HorizontalAlignment = xlHAlignCenter
                .VerticalAlignment = xlVAlignCenter
            End With
            With .ThreeD
                .BevelTopType = msoBevelArtDeco
                .BevelTopInset = 9
                .BevelTopDepth = 6
            End With
            .OnAction = "exeBeHere"
        End With
    End With
    nmlTmn = True
setSht_Exit:
    'エラーを無視
    On Error Resume Next
    Call ReSetObject
    Call Updating
    If nmlTmn Then
        MsgBox " 完了♪"
    End If
    'エラー制御を戻す
    On Error GoTo 0
    Exit Sub
setSht_Err:
    Bln_Err = True
    MsgBox "実行時エラー:" & Err.Nuer & "" & _
        Err.Description & vbCr & _
       "処理を終了します。", vbExclamation, ErrProsName
    Err.Clear      'エラー情報クリア
    GoTo setSht_Exit
End Sub

'====================================================
'   I'm here. TOOL
'====================================================
Sub exeBeHere()
    Dim cnt As Long
    Dim tgtM As Long
    Dim x As Long
    Dim MaxNo As Long
    Dim SttTime As Date
    Dim EndTime As Date
    Dim ErrProsName As String
    Dim nmlTmn As Boolean       '正常終了フラグ:normal Termination


    Bln_Err = False
    nmlTmn = False
    ErrProsName = "exeBeHere"
    On Error GoTo exeBeHere_Err


    '[Esc]キーでエラーをトラップする
    Application.EnableCancelKey = xlErrorHandler
    nmlTmn = False
    Call showStatus("I'm Here")
    Call SetObject


'=====================================================
    With wsMain
        tgtM = .Cells(7, 3)
        SttTime = Now()
        .Cells(7, 5) = ""
        .Cells(10, 3) = Format(SttTime, "hh:mm:ss")
        .Cells(9, 5) = "Now"
        .Cells(10, 5) = ""
        .Cells(10, 7) = ""
        .Cells(7, 5).Select
        If tgtM = 0 Then
            MsgBox "設定時間を選択してください。" & vbCr & _
               "処理を終了します。", vbExclamation
            Err.Clear          'エラー情報クリア
            GoTo exeBeHere_Exit
        End If

        MaxNo = tgtM * 3
        Select Case tgtM
            Case 1
                EndTime = SttTime + TimeValue("0:01:00")
            Case 3
                EndTime = SttTime + TimeValue("0:03:00")
            Case 5
                EndTime = SttTime + TimeValue("0:05:00")
            Case 10
                EndTime = SttTime + TimeValue("0:10:00")
            Case 15
                EndTime = SttTime + TimeValue("0:15:00")
            Case 30
                EndTime = SttTime + TimeValue("0:30:00")
            Case 45
                EndTime = SttTime + TimeValue("0:45:00")
            Case 60
                EndTime = SttTime + TimeValue("1:00:00")
            Case 90
                EndTime = SttTime + TimeValue("1:30:00")
        End Select


        '[Esc]キーでエラーをトラップする
        Application.EnableCancelKey = xlErrorHandler
        GoTo There
        .Cells(7, 5).Select
        MaxNo = 10
        Do While Now < EndTime
            On Error GoTo There
            If .Cells(7, 5) = "" Then
                '機能を見える化的演出
                If x Mod 2 = 0 Then
                    SendKeys "{down}"
                Else
                    SendKeys "{Up}"
                End If
                x = x + 1
                Application.Wait (Now + TimeValue("0:00:05"))
                .Cells(10, 5) = Format(Now, "hh:mm:ss")
                .Cells(10, 7) = x
                DoEvents
            Else
                GoTo exeBeHere_Err
            End If
There:
            If Err.Number > 0 Then
                Select Case Err.Number

           '【esc】キーが押された場合
                    Case 18

                        If MsgBox("終了しますか?", vbQuestion + vbYesNo) = vbNo Then
                            Resume
                        Else
                            .Cells(7, 5) = "中断"
                            GoTo exeBeHere_Exit
                        End If
                        Err.Clear
                        On Error GoTo 0

          'その他のエラーの場合
                    Case Else
                        Debug.Print Err.Number
                        Debug.Print Err.Description
                        Err.Clear
                        On Error GoTo 0
                End Select
            End If
        Loop
    End With
    nmlTmn = True


exeBeHere_Exit:
    'エラーを無視
    On Error Resume Next
    With wsMain
        .Cells(9, 5) = "End"
        .Cells(10, 5) = Format(Time, "hh:mm:ss")
    End With
    Call ReSetObject
    Call Updating
    Call ClearStatus
    If nmlTmn Then
        MsgBox " 終了♪"
    End If
    'エラー制御を戻す
    On Error GoTo 0
    Exit Sub
exeBeHere_Err:
    Bln_Err = True
    If Err.Number = 18 Then
        If MsgBox("マクロを終了しますか?", vbYesNo) = vbYes Then
            GoTo exeBeHere_Exit
        Else
            Resume
        End If
    Else
        'その他のエラー
        MsgBox "実行時エラー:" & Err.Number & "" & _
            Err.Description & vbCr & _
           "処理を終了します。", vbExclamation, ErrProsName
        Err.Clear         'エラー情報クリア
        GoTo exeBeHere_Exit
    End If
End Sub

コメント

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