Template-YYY_Whisper

Excel VBA
2025.10.25 
Excel VBAマクロ「BeHereForm」の解説

このマクロは、Microsoft Teamsのステータスを「在席中（緑）」のまま維持するための補助ツールです。
Excel上で簡単な操作を行い続けることで、PCがアクティブ状態と認識され、ステータスが自動で「退席中」になるのを防ぎます。

🔹主な機能
UserForm（BeHereForm）を表示して、作業中のブックを開いたまま時間を選択
指定した時間（分）だけ、選択セルのある行のA列に対して上下キーを交互に送信
1分ごとにステータスバーに残り時間を表示
[Esc]キーで中断可能 （実際には、[Esc]キーで中断できない場合があるので、別のウィンドウに移動し、エラー終了で止める）
終了時にステータスバーをクリアし、通知メッセージを表示

🔹使い方の流れ
Excelで任意のセルを選択
ShowBeHereForm マクロを実行 → フォームが表示される
時間を選択して「開始」ボタンを押す
指定時間中、Excelが自動でキー操作を行い続ける

🔹目的の一例
Teamsのステータスを「在席中（緑）」に保ちたいときに便利です。 離席していてもPCが操作されていると認識されるため、ステータスが変わりません。

🔹主な機能
UserForm（BeHereForm）を表示して、作業中のブックを開いたまま時間を選択
指定した時間（分）だけ、選択セルのある行のA列に対して上下キーを交互に送信
1分ごとにステータスバーに残り時間を表示
[Esc]キーで中断可能（環境により、効かない場合もあります。）
終了時にステータスバーをクリアし、通知メッセージを表示

🔹使い方の流れ
Excelで任意のセルを選択
ShowBeHereForm マクロを実行 → フォームが表示される
時間を選択して「開始」ボタンを押す
指定時間中、Excelが自動でキー操作を行い続ける

🔹目的の一例
Teamsのステータスを「在席中（緑）」に保ちたいときに便利です。 離席していてもPCが操作されていると認識されるため、ステータスが変わりません。


フォーム名：BeHereForm
コントロール一覧：
　・ComboBox：cmbMinutes
　・CommandButton：cmdStart

  1. ①フォームを作成を標準モジュールで実行（【F5】キーを押下する）
  2. 作成されたフォームに②フォームのコードをコピーし、ユーザーフォームのコード欄に貼り付ける。 選択項目を変更するならこのタイミングで！
  3. 標準モジュールを追加し、【YYY_Whisper】とする。
    ③のコードを貼り付ける。
 ※ 選択項目をあとから追加する場合は、ComboBox のプロパティLstRows を項目数に合わせて変更して使用します。変更を忘れるとエラーが出ます。
　標準モジュール：Y01_CreateBeHereForm　①フォームを作成
Option Explicit
'+++*********************************************************+++
'  Sub：CreateBeHereForm
'             ・ユーザーフォーム「BeHereForm」を自動生成するマクロ
'             ・フォームサイズ、フォント、各コントロールを指定して作成
'             ・ラベル：時間選択の案内文を表示
'             ・コンボボックス：分単位の選択肢を入力する欄
'             ・コマンドボタン：選択した時間で処理を開始する起点ボタン
'             ・このマクロを実行すると、プロジェクトに新しいフォームが追加される
'+++*********************************************************+++
Private Sub CreateBeHereForm()

    Dim myForm As Object
    Dim myFormDesign As Object
    
    ' ユーザーフォームを追加
    Set myForm = ThisWorkbook.VBProject.VBComponents.Add(ComponentType:=3)
    
    With myForm
        .Name = "BeHereForm"
        .Properties("Height") = 99
        .Properties("Width") = 209.5
        .Properties("Caption") = "BeHereForm"
    End With
    
    Set myFormDesign = myForm.Designer
    
    ' ラベル
    With myFormDesign.Controls.Add("Forms.Label.1")
        .Name = "lblSelectTime"
        .Caption = "時間を選択します"
        .Width = 84
        .Height = 12
        .Left = 18
        .Top = 12
        .Font.Name = "BIZ UDP ゴシック"
        .Font.Size = 9
    End With
    
    ' コンボボックス
    With myFormDesign.Controls.Add("Forms.ComboBox.1")
        .Name = "cmbMinutes"
        .ColumnCount = 1
        .Width = 72
        .Height = 18
        .Left = 18
        .Top = 36
        .Font.Name = "BIZ UDP ゴシック"
        .Font.Size = 9
    End With
    
    ' コマンドボタン
    With myFormDesign.Controls.Add("Forms.CommandButton.1")
        .Name = "cmdStart"
        .Caption = "開    始"
        .Width = 66
        .Height = 18
        .Left = 114
        .Top = 36
        .Font.Name = "BIZ UDP ゴシック"
        .Font.Size = 9
    End With

End Sub
　UserForm名：BeHereForm　　②フォームのコード
Option Explicit

Private Sub UserForm_Initialize()
    With cmbMinutes
        .AddItem "1"
        .AddItem "3"
        .AddItem "5"
        .AddItem "10"
        .AddItem "15"
        .AddItem "20"
        .AddItem "30"
        .AddItem "50"
        .AddItem "60"
        .AddItem "90"
        .AddItem "120"
        .ListIndex = 2 ' 初期値：5分
    End With
End Sub

Private Sub cmdStart_Click()
    Dim minVal As Long
    If cmbMinutes.Value = "" Then
        MsgBox "時間を選択してください", vbExclamation
        Exit Sub
    End If
    minVal = CLng(cmbMinutes.Value)
    Me.Hide
    Call BeHereStart(minVal)
End Sub
　標準モジュール：YYY_Whisper ③標準モジュールに貼り付け、起点マクロをリボンに登録
'+++*********************************************************+++
'  Main Sub：UserForm をモードレスで表示する起点マクロ
'             ・作業中のブックを開いたままフォーム操作が可能
'             ・フォーム側で時間を選択し、SendKeys 処理を開始
'+++*********************************************************+++
Sub ShowBeHereForm()
    BeHereForm.Show vbModeless
End Sub
'+++*********************************************************+++
'  BeHereStart：SendKeys による気配残し処理の本体
'                ・選択セルの行の A列に対して上下キーを送信
'                ・指定時間（分）だけループ処理を継続
'                ・1分ごとにステータスバーに残り時間を表示
'                ・[Esc]キーで中断可能
'                ・終了時にステータスバーをクリア
'+++*********************************************************+++
Sub BeHereStart(durationMinutes As Long)
    Dim startTime As Date
    Dim endTime As Date
    Dim x As Long
    Dim targetRow As Long
    Dim lastShownMinute As Long
    Dim remainingMinutes As Long

    On Error GoTo ErrHandler

    If TypeName(Selection) <> "Range" Then
        MsgBox "セルを選択してください", vbExclamation
        Exit Sub
    End If

    targetRow = ActiveCell.Row
    If targetRow = 0 Then
        MsgBox "セルを選択してください", vbExclamation
        Exit Sub
    End If

    ' A列の対象セルを選択
    Cells(targetRow, 1).Select

    startTime = Now
    endTime = DateAdd("n", durationMinutes, startTime)
    lastShownMinute = durationMinutes

    ' 初期ステータス表示
    Call showStatus(durationMinutes & "分で設定：あと " & durationMinutes & "分")

    Application.EnableCancelKey = xlErrorHandler
    Do While Now < endTime
        ' 1分ごとにステータス更新
        remainingMinutes = Int(DateDiff("s", Now, endTime) / 60)
        If remainingMinutes < lastShownMinute Then
            lastShownMinute = remainingMinutes
            If remainingMinutes > 0 Then
                Call showStatus(durationMinutes & "分で設定：あと " & remainingMinutes & "分")
            Else
                Call showStatus("まもなく終了します…")
            End If
        End If

        If x Mod 2 = 0 Then
            SendKeys "{DOWN}"
        Else
            SendKeys "{UP}"
        End If
        x = x + 1
        Application.Wait Now + TimeValue("0:00:10")
        DoEvents
    Loop

    Call ClearStatus
    MsgBox "終了しました♪", vbInformation
    Exit Sub

ErrHandler:
    Call ClearStatus
    If Err.Number = 18 Then
        If MsgBox("中断しますか？", vbYesNo + vbQuestion) = vbYes Then
            MsgBox "中断しました", vbExclamation
        Else
            Resume
        End If
    Else
        MsgBox "エラー：" & Err.Number & vbCrLf & Err.Description, vbCritical
    End If
End Sub

コメント

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