OutlookVBA:メール送信キャンセル

Option Explicit

Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    Dim i As Long, k As Variant
    Dim sec As Long
    Dim cancelKeys As Variant

    ' ===== キャンセル対象キー一覧 =====
     cancelKeys = Array(27, 13, 32, 9, 8, 46, 45, 36, 35, 33, 34)

    ' ===== ① 送信操作で押されたキーが「完全に離される」まで待つ =====
    Do
        DoEvents
        Sleep 50
    Loop While IsAnyKeyPressed(cancelKeys)

    ' ===== ② カウントダウン & キー監視（5秒） =====
    For i = 50 To 1 Step -1
        DoEvents
        Sleep 100

        sec = (i + 9) \ 10

        If IsAnyKeyPressed(cancelKeys) Then
            Cancel = True

            On Error Resume Next
            Item.Save
            On Error GoTo 0

            MsgBox "特殊キーが押されたため送信をキャンセルしました。" & vbCrLf & _
                   "内容は下書きに保存されています。", vbExclamation
            Exit Sub
        End If
    Next i


End Sub
Private Function IsAnyKeyPressed(keyArray As Variant) As Boolean
    Dim k As Variant
    For Each k In keyArray
        ' ★ 押された瞬間も確実に拾う版
        If GetAsyncKeyState(k) <> 0 Then
            IsAnyKeyPressed = True
            Exit Function
        End If
    Next
End Function