Template-YYY_Whisper

Option Explicit　

'+++*********************************************************+++
'  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