MENU

Excel VBAを利用したOutlookの自動返信スケジューリングの実装方法

VBA

Excel VBAを利用したOutlookの自動返信スケジューリングの実装方法では、ActiveExplorerで選択されたMailItem一件からReplyを作り、future時刻と本文を設定してDisplay確認後にSendする。MailItem.Replyは元mailに対応する返信itemを作り、DeferredDeliveryTimeは将来配信時刻を設定する。Outlook Ruleや不在応答とは別で、一件の選択mailに対する予約送信itemである。この記事はoriginal EntryID、conversation ID、reply recipient、future time、plan rowを返信requestにするを判断軸にして、記事固有のコード、合否、停止条件、復元を順序立てて説明します。

新規mailではなく、選択した一件のthreadへ将来時刻付き予約返信を作る。完了は「元Conversationを引き継ぐreplyを一つSendし、宛先、引用、future時刻、Queued状態がplanと一致する」です。結果が空なら「選択0件・複数件、MailItem以外、返信先なしなら作らず、任意addressへ新規mailを送らない」として調べ、エラーを0件へ置き換えません。

目次

auto-reply ruleと一回返信を区別

ActiveExplorerで選択されたMailItem一件からReplyを作り、future時刻と本文を設定してDisplay確認後にSendする。選択メールへの承認済み遅延返信では、単にコマンドが終了したことではなく「元Conversationを引き継ぐreplyを一つSendし、宛先、引用、future時刻、Queued状態がplanと一致する」を完了条件にします。新規mailではなく、選択した一件のthreadへ将来時刻付き予約返信を作る。

auto-reply ruleと一回返信を区別に入る前に、対象、実行場所、権限、入力の由来を確認します。選択0件・複数件、MailItem以外、返信先なしなら作らず、任意addressへ新規mailを送らない。判定不能を成功へ丸めません。

選択MailItemを一件だけ確認

選択MailItemを一件だけ確認は変更や出力生成より先に行う観測です。original EntryID、conversation ID、reply recipient、future time、plan rowを返信requestにするを含む形で現状を保存し、後段のコードが同じ対象へ向くか確認します。

Option Explicit

Private Const olMailItemClass As Long = 43
Private Const olFolderOutbox As Long = 4
Private Const olFolderSentMail As Long = 5
Private Const olTextProperty As Long = 1
Private Const olDiscard As Long = 1

Private Function NewReplyAttemptId() As String
    Dim typeLib As Object, raw As String, details As String
    On Error GoTo Failed
    Set typeLib = CreateObject("Scriptlet.TypeLib")
    raw = Replace$(Replace$(CStr(typeLib.GUID), "{", vbNullString), "}", vbNullString)
    If Len(raw) <> 36 Then Err.Raise 5, , "GUID length mismatch"
    NewReplyAttemptId = "reply-" & raw
    Exit Function
Failed:
    details = CStr(Err.Number) & " " & Err.Description
    On Error GoTo 0
    Err.Raise vbObjectError + 1860, "NewReplyAttemptId", "AttemptIDを生成できません。queueしません: " & details
End Function

Private Sub StampReplyAttempt(ByVal mail As Object, ByVal attemptId As String)
    Dim prop As Object
    Set prop = mail.UserProperties.Find("ExcelAttemptID", True)
    If prop Is Nothing Then Set prop = mail.UserProperties.Add("ExcelAttemptID", olTextProperty, True)
    prop.Value = attemptId
    If CStr(prop.Value) <> attemptId Then Err.Raise 5, , "outbound AttemptIDをMailItemへ設定できません"
End Sub

Private Function RecipientSmtpAddress(ByVal recipient As Object) As String
    Dim addressEntry As Object, exchangeUser As Object, smtp As String, details As String
    On Error GoTo Failed
    Set addressEntry = recipient.AddressEntry
    If addressEntry Is Nothing Then Err.Raise 5, , "AddressEntryがありません"
    If UCase$(CStr(addressEntry.Type)) = "EX" Then
        On Error Resume Next
        Set exchangeUser = addressEntry.GetExchangeUser
        If Not exchangeUser Is Nothing Then smtp = CStr(exchangeUser.PrimarySmtpAddress)
        If Len(Trim$(smtp)) = 0 Then smtp = CStr(addressEntry.PropertyAccessor.GetProperty("http" & "://schemas.microsoft.com/mapi/proptag/0x39FE001E"))
        Err.Clear
        On Error GoTo Failed
    Else
        smtp = CStr(addressEntry.Address)
    End If
    smtp = LCase$(Trim$(smtp))
    If Len(smtp) = 0 Or InStr(1, smtp, "@", vbBinaryCompare) = 0 Then Err.Raise 5, , "canonical SMTP addressを取得できません"
    RecipientSmtpAddress = smtp
    Exit Function
Failed:
    details = CStr(Err.Number) & " " & Err.Description
    On Error GoTo 0
    Err.Raise vbObjectError + 1866, "RecipientSmtpAddress", "SMTP正規化失敗: " & details
End Function

Private Function CanonicalRecipientTuple(ByVal mail As Object) As String
    Dim values As Object, recipient As Object, keys As Variant, i As Long, j As Long, swapValue As String, smtp As String
    Set values = CreateObject("Scripting.Dictionary")
    values.CompareMode = vbTextCompare
    For Each recipient In mail.Recipients
        smtp = RecipientSmtpAddress(recipient)
        If values.Exists(smtp) Then Err.Raise 5, , "同じSMTP recipientが重複しています: " & smtp
        values.Add smtp, True
    Next recipient
    If values.Count = 0 Then Err.Raise 5, , "canonical recipient tupleが空です"
    keys = values.Keys
    For i = LBound(keys) To UBound(keys) - 1
        For j = i + 1 To UBound(keys)
            If StrComp(CStr(keys(i)), CStr(keys(j)), vbBinaryCompare) > 0 Then
                swapValue = CStr(keys(i))
                keys(i) = keys(j)
                keys(j) = swapValue
            End If
        Next j
    Next i
    CanonicalRecipientTuple = Join(keys, ";")
End Function

Private Function StableTextDigest(ByVal value As String) As String
    Dim hashValue As Double, codePoint As Long, i As Long
    For i = 1 To Len(value)
        codePoint = AscW(Mid$(value, i, 1))
        If codePoint < 0 Then codePoint = codePoint + 65536
        hashValue = hashValue * 131# + CDbl(codePoint)
        hashValue = hashValue - Fix(hashValue / 2147483629#) * 2147483629#
    Next i
    StableTextDigest = Right$("00000000" & Hex$(CLng(hashValue)), 8) & "-" & CStr(Len(value))
End Function

Private Function ReplyMessageDigest(ByVal mail As Object, ByVal canonicalRecipients As String, ByVal expectedAt As Date) As String
    ReplyMessageDigest = StableTextDigest(CStr(mail.Subject) & vbLf & CStr(mail.Body) & vbLf & canonicalRecipients & vbLf & Format$(expectedAt, "yyyy-mm-dd hh:nn:ss"))
End Function

Private Sub PersistReplyState(ByVal ws As Worksheet, ByVal expectedState As String, ByVal expectedSource As String, ByVal expectedAttemptId As String, ByVal expectedRecipient As String, ByVal expectedDigest As String, ByVal expectedAt As Date)
    Dim saveNumber As Long, saveDescription As String
    If Len(ThisWorkbook.Path) = 0 Then Err.Raise 5, , "未保存workbookでは耐久状態を作れません"
    If ThisWorkbook.ReadOnly Then Err.Raise 5, , "read-only workbookでは耐久状態を作れません"
    On Error Resume Next
    ThisWorkbook.Save
    saveNumber = Err.Number
    saveDescription = Err.Description
    Err.Clear
    On Error GoTo 0
    If saveNumber <> 0 Then Err.Raise vbObjectError + 1861, "PersistReplyState", "ThisWorkbook.Save失敗: " & CStr(saveNumber) & " " & saveDescription
    If Not ThisWorkbook.Saved Then Err.Raise vbObjectError + 1862, "PersistReplyState", "Save後もThisWorkbook.Saved=Falseです"
    If StrComp(CStr(ws.Range("F2").Value2), expectedState, vbBinaryCompare) <> 0 Then Err.Raise 5, , "保存後state再読不一致"
    If StrComp(CStr(ws.Range("G2").Value2), expectedSource, vbBinaryCompare) <> 0 Then Err.Raise 5, , "保存後source identity再読不一致"
    If StrComp(CStr(ws.Range("I2").Value2), expectedAttemptId, vbBinaryCompare) <> 0 Then Err.Raise 5, , "保存後AttemptID再読不一致"
    If StrComp(CStr(ws.Range("J2").Value2), expectedRecipient, vbBinaryCompare) <> 0 Then Err.Raise 5, , "保存後recipient再読不一致"
    If StrComp(CStr(ws.Range("K2").Value2), expectedDigest, vbBinaryCompare) <> 0 Then Err.Raise 5, , "保存後message digest再読不一致"
    If Not IsDate(ws.Range("D2").Value) Then Err.Raise 13, , "保存後DeferredDeliveryTimeがありません"
    If CDbl(CDate(ws.Range("D2").Value)) <> CDbl(expectedAt) Then Err.Raise 5, , "保存後DeferredDeliveryTime再読不一致"
    If CStr(ws.Range("H2").Value2) <> "ApprovedToQueue" Then Err.Raise 5, , "保存後approval再読不一致"
End Sub

Private Function CountReplyAttemptInFolder(ByVal folder As Object, ByVal attemptId As String, ByVal expectedRecipient As String, ByVal expectedDigest As String, ByVal expectedAt As Date, ByRef mismatchCount As Long) As Long
    Dim item As Object, prop As Object
    For Each item In folder.Items
        If item.Class = olMailItemClass Then
            Set prop = Nothing
            On Error Resume Next
            Err.Clear
            Set prop = item.UserProperties.Find("ExcelAttemptID", True)
            Err.Clear
            On Error GoTo 0
            If Not prop Is Nothing Then
                If CStr(prop.Value) = attemptId Then
                    CountReplyAttemptInFolder = CountReplyAttemptInFolder + 1
                    Debug.Print "attemptMatch=" & attemptId, "folder=" & folder.FolderPath, "entry=" & item.EntryID
                    If StrComp(CanonicalRecipientTuple(item), expectedRecipient, vbBinaryCompare) <> 0 Then mismatchCount = mismatchCount + 1
                    If Not IsDate(item.DeferredDeliveryTime) Then
                        mismatchCount = mismatchCount + 1
                    ElseIf Abs(DateDiff("s", CDate(item.DeferredDeliveryTime), expectedAt)) > 1 Then
                        mismatchCount = mismatchCount + 1
                    End If
                    If StrComp(ReplyMessageDigest(item, expectedRecipient, expectedAt), expectedDigest, vbBinaryCompare) <> 0 Then mismatchCount = mismatchCount + 1
                End If
            End If
        End If
    Next item
End Function

Private Sub PersistReplyReset(ByVal ws As Worksheet, ByVal closedAttemptId As String, ByVal closedOutcome As String, ByVal closedAt As Date)
    Dim saveNumber As Long, saveDescription As String
    If Len(ThisWorkbook.Path) = 0 Or ThisWorkbook.ReadOnly Then Err.Raise 5, , "resetを保存できるwritable workbookが必要です"
    On Error Resume Next
    ThisWorkbook.Save
    saveNumber = Err.Number
    saveDescription = Err.Description
    Err.Clear
    On Error GoTo 0
    If saveNumber <> 0 Then Err.Raise vbObjectError + 1867, "PersistReplyReset", "ThisWorkbook.Save失敗: " & CStr(saveNumber) & " " & saveDescription
    If Not ThisWorkbook.Saved Then Err.Raise 5, , "reset Save後もThisWorkbook.Saved=Falseです"
    If CStr(ws.Range("F2").Value2) <> "Ready" Then Err.Raise 5, , "reset後state再読不一致"
    If Len(CStr(ws.Range("G2").Value2)) > 0 Or Len(CStr(ws.Range("H2").Value2)) > 0 Or Len(CStr(ws.Range("I2").Value2)) > 0 Or Len(CStr(ws.Range("J2").Value2)) > 0 Or Len(CStr(ws.Range("K2").Value2)) > 0 Or Len(CStr(ws.Range("L2").Value2)) > 0 Then Err.Raise 5, , "reset後に旧attempt tupleまたはapprovalが残っています"
    If CStr(ws.Range("M2").Value2) <> closedAttemptId Or CStr(ws.Range("N2").Value2) <> closedOutcome Then Err.Raise 5, , "closed attempt archive再読不一致"
    If Not IsDate(ws.Range("O2").Value) Then Err.Raise 5, , "closedAtがありません"
    If CDbl(CDate(ws.Range("O2").Value)) <> CDbl(closedAt) Then Err.Raise 5, , "closedAt再読不一致"
End Sub

Sub InspectSelectedReplySource()
    Dim olApp As Object, explorer As Object, original As Object, ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("ReplyPlan")
    Set olApp = GetObject(, "Outlook.Application")
    Set explorer = olApp.ActiveExplorer
    If explorer Is Nothing Or explorer.Selection.Count <> 1 Then Err.Raise 5, , "返信元MailItemを1件だけ選択してください"
    Set original = explorer.Selection.Item(1)
    If original.Class <> olMailItemClass Or Len(CStr(original.EntryID)) = 0 Then Err.Raise 5, , "保存済みMailItemを選択してください"
    Debug.Print "EntryID=" & original.EntryID, "Subject=" & original.Subject
        Debug.Print "State=" & ws.Range("F2").Value2, "Source=" & ws.Range("G2").Value2, "Attempt=" & ws.Range("I2").Value2
    Debug.Print "reopenPolicy=inspect/reconcile only; no automatic Send"
End Sub

MailItem.Replyは元mailに対応する返信itemを作り、DeferredDeliveryTimeは将来配信時刻を設定する。Outlook Ruleや不在応答とは別で、一件の選択mailに対する予約送信itemである。選択メールへの承認済み遅延返信では取得不能、対象なし、値が空という三状態を分け、stderrや終了コードを捨てません。

Replyでthreadを維持

Replyでthreadを維持ではActiveExplorerで選択されたMailItem一件からReplyを作り、future時刻と本文を設定してDisplay確認後にSendする。選択メールへの承認済み遅延返信のサンプルにあるパス、セル、ユーザー、時刻は検証用なので、直前に確認した承認値へ置き換えます。

Sub QueueApprovedDeferredReply()
    Dim ws As Worksheet, olApp As Object, explorer As Object, original As Object, rebound As Object, reply As Object, attemptProp As Object
    Dim atTime As Date, answer As VbMsgBoxResult, sourceEntryId As String, sourceStoreId As String, sourceIdentity As String
    Dim attemptId As String, expectedRecipient As String, expectedDigest As String, failureText As String, persistText As String
    Set ws = ThisWorkbook.Worksheets("ReplyPlan")
    If StrComp(Trim$(CStr(ws.Range("H2").Value2)), "ApprovedToQueue", vbBinaryCompare) <> 0 Then Err.Raise 5, , "ApprovedToQueueの明示承認がありません"
    If CStr(ws.Range("F2").Value2) <> "Ready" Or Len(CStr(ws.Range("G2").Value2)) > 0 Or Len(CStr(ws.Range("I2").Value2)) > 0 Or Len(CStr(ws.Range("K2").Value2)) > 0 Then Err.Raise 5, , "新しいReady requestだけをqueueできます"
    If Not IsDate(ws.Range("D2").Value) Then Err.Raise 13, , "返信予定が日付ではありません"
    atTime = CDate(ws.Range("D2").Value)
    If atTime <= Now Then Err.Raise 5, , "未来時刻を指定してください"
    Set olApp = GetObject(, "Outlook.Application")
    Set explorer = olApp.ActiveExplorer
    If explorer Is Nothing Or explorer.Selection.Count <> 1 Then Err.Raise 5, , "返信元MailItemを1件だけ選択してください"
    Set original = explorer.Selection.Item(1)
    If original.Class <> olMailItemClass Or Len(CStr(original.EntryID)) = 0 Then Err.Raise 5, , "保存済みMailItemではありません"
    sourceEntryId = CStr(original.EntryID)
    sourceStoreId = CStr(original.Parent.StoreID)
    sourceIdentity = sourceStoreId & "|" & sourceEntryId
    attemptId = NewReplyAttemptId()
    Set reply = original.Reply
    With reply
        .DeferredDeliveryTime = atTime
        .Body = CStr(ws.Range("E2").Value2) & vbCrLf & vbCrLf & .Body
        If Not .Recipients.ResolveAll Then Err.Raise 5, , "返信先を解決できません"
        .Display
    End With
    expectedRecipient = CanonicalRecipientTuple(reply)
    expectedDigest = ReplyMessageDigest(reply, expectedRecipient, atTime)
    answer = MsgBox("返信先・引用・予定時刻・source identityを確認し、この1件だけをqueueしますか。", vbYesNo + vbQuestion, "返信送信の最終確認")
    If answer <> vbYes Then
        On Error Resume Next
        reply.Close olDiscard
        On Error GoTo 0
        ws.Range("F2").Value2 = "Cancelled"
        ws.Range("G2").Value2 = sourceIdentity
        ws.Range("I2").Value2 = attemptId
        ws.Range("J2").Value2 = expectedRecipient
        ws.Range("K2").Value2 = expectedDigest
        PersistReplyState ws, "Cancelled", sourceIdentity, attemptId, expectedRecipient, expectedDigest, atTime
        Exit Sub
    End If
    If Not reply.Recipients.ResolveAll Then Err.Raise 5, , "最終確認後に返信先を解決できません"
    If Not IsDate(reply.DeferredDeliveryTime) Then Err.Raise 5, , "Inspector確認後にDeferredDeliveryTimeがありません"
    If Abs(DateDiff("s", CDate(reply.DeferredDeliveryTime), atTime)) > 1 Then Err.Raise 5, , "Inspector確認後にDeferredDeliveryTimeが変更されました"
    expectedRecipient = CanonicalRecipientTuple(reply)
    expectedDigest = ReplyMessageDigest(reply, expectedRecipient, atTime)
    StampReplyAttempt reply, attemptId
    ws.Range("F2").Value2 = "Queueing"
    ws.Range("G2").Value2 = sourceIdentity
    ws.Range("I2").Value2 = attemptId
    ws.Range("J2").Value2 = expectedRecipient
    ws.Range("K2").Value2 = expectedDigest
    PersistReplyState ws, "Queueing", sourceIdentity, attemptId, expectedRecipient, expectedDigest, atTime
    On Error GoTo QueueUnknown
    reply.Save
    Set attemptProp = reply.UserProperties.Find("ExcelAttemptID", True)
    If attemptProp Is Nothing Or CStr(attemptProp.Value) <> attemptId Then Err.Raise 5, , "保存draftのAttemptIDを再読できません"
    If CanonicalRecipientTuple(reply) <> expectedRecipient Or ReplyMessageDigest(reply, expectedRecipient, atTime) <> expectedDigest Then Err.Raise 5, , "Send直前のrecipient/subject/body digestが保存tupleと一致しません"
    Set rebound = olApp.Session.GetItemFromID(sourceEntryId, sourceStoreId)
    If rebound Is Nothing Or rebound.Class <> olMailItemClass Or CStr(rebound.EntryID) <> sourceEntryId Then Err.Raise 5, , "Send直前に同じsource MailItemを再取得できません"
    reply.Send
    ws.Range("F2").Value2 = "Queued"
    PersistReplyState ws, "Queued", sourceIdentity, attemptId, expectedRecipient, expectedDigest, atTime
    Exit Sub
QueueUnknown:
    failureText = CStr(Err.Number) & " " & Err.Description
    On Error Resume Next
    Err.Clear
    ws.Range("F2").Value2 = "QueueUnknown"
    PersistReplyState ws, "QueueUnknown", sourceIdentity, attemptId, expectedRecipient, expectedDigest, atTime
    If Err.Number <> 0 Then persistText = "; unknown-state save also failed: " & CStr(Err.Number) & " " & Err.Description
    On Error GoTo 0
    Err.Raise vbObjectError + 1863, "QueueApprovedDeferredReply", "queue結果は未確定です。自動再送せずOutbox/SentをAttemptIDで照合します: " & failureText & persistText
End Sub

外部自動返信loopや機密引用を防ぐため無条件Sendは行わず、ApprovedToQueueの一件を人が確認してからSendする。選択メールへの承認済み遅延返信で変更が発生する場合は、新規出力、no-clobber、WhatIf、予約送信item表示など利用可能な安全機構を先に使います。

future DeferredDeliveryTimeを設定

future DeferredDeliveryTimeを設定では入力と出力を別々に再取得します。選択メールへの承認済み遅延返信の合格は、元Conversationを引き継ぐreplyを一つSendし、宛先、引用、future時刻、Queued状態がplanと一致することです。件数だけでなく識別値と内容も照合します。

Sub ReconcileQueuedReply()
    Dim ws As Worksheet, olApp As Object, session As Object, state As String
    Dim attemptId As String, sourceIdentity As String, expectedRecipient As String, expectedDigest As String, atTime As Date
    Dim matchCount As Long, mismatchCount As Long
    Set ws = ThisWorkbook.Worksheets("ReplyPlan")
    state = CStr(ws.Range("F2").Value2)
    Select Case state
        Case "Queueing", "QueueUnknown", "QueueUnresolved", "QueueAmbiguous"
        Case Else
            Err.Raise 5, , "照合対象のdurable queue stateではありません"
    End Select
    attemptId = CStr(ws.Range("I2").Value2)
    sourceIdentity = CStr(ws.Range("G2").Value2)
    expectedRecipient = CStr(ws.Range("J2").Value2)
    expectedDigest = CStr(ws.Range("K2").Value2)
    If Len(attemptId) = 0 Or Len(sourceIdentity) = 0 Or Len(expectedRecipient) = 0 Or Len(expectedDigest) = 0 Or Not IsDate(ws.Range("D2").Value) Then Err.Raise 5, , "照合tupleが不足しています"
    atTime = CDate(ws.Range("D2").Value)
    Set olApp = GetObject(, "Outlook.Application")
    Set session = olApp.Session
    matchCount = CountReplyAttemptInFolder(session.GetDefaultFolder(olFolderOutbox), attemptId, expectedRecipient, expectedDigest, atTime, mismatchCount)
    matchCount = matchCount + CountReplyAttemptInFolder(session.GetDefaultFolder(olFolderSentMail), attemptId, expectedRecipient, expectedDigest, atTime, mismatchCount)
    If mismatchCount > 0 Or matchCount > 1 Then
        ws.Range("F2").Value2 = "QueueAmbiguous"
        PersistReplyState ws, "QueueAmbiguous", sourceIdentity, attemptId, expectedRecipient, expectedDigest, atTime
        Err.Raise vbObjectError + 1864, "ReconcileQueuedReply", "AttemptID一致が複数またはtuple不一致です。自動再送しません"
    ElseIf matchCount = 0 Then
        ws.Range("F2").Value2 = "QueueUnresolved"
        PersistReplyState ws, "QueueUnresolved", sourceIdentity, attemptId, expectedRecipient, expectedDigest, atTime
        Err.Raise vbObjectError + 1865, "ReconcileQueuedReply", "Outbox/Sentに一致なしです。未送信と断定せず明示再承認まで停止します"
    Else
        ws.Range("F2").Value2 = "Queued"
        PersistReplyState ws, "Queued", sourceIdentity, attemptId, expectedRecipient, expectedDigest, atTime
    End If
End Sub

Sub ResolveReplyAttemptForReapproval()
    Dim ws As Worksheet, state As String, attemptId As String, approval As String, closedAt As Date
    Set ws = ThisWorkbook.Worksheets("ReplyPlan")
    state = CStr(ws.Range("F2").Value2)
    attemptId = CStr(ws.Range("I2").Value2)
    approval = CStr(ws.Range("L2").Value2)
    If state = "QueueUnresolved" Then
        If Not IsDate(ws.Range("D2").Value) Then Err.Raise 5, , "DeferredDeliveryTimeがありません"
        If Now <= CDate(ws.Range("D2").Value) + TimeSerial(0, 5, 0) Then Err.Raise 5, , "DeferredDeliveryTime後5分まではno-match再承認できません"
        If approval <> "ReapproveNoMatch:" & attemptId Then Err.Raise 5, , "L2へReapproveNoMatch:<AttemptID>が必要です"
    ElseIf state = "QueueAmbiguous" Then
        If approval <> "DuplicatesResolved:" & attemptId Then Err.Raise 5, , "L2へDuplicatesResolved:<AttemptID>が必要です"
    Else
        Err.Raise 5, , "reapprovalへ進める照合stateではありません"
    End If
    closedAt = Now
    ws.Range("M2").Value2 = attemptId
    ws.Range("N2").Value2 = state
    ws.Range("O2").Value2 = closedAt
    ws.Range("F2").Value2 = "Ready"
    ws.Range("G2").ClearContents
    ws.Range("H2").ClearContents
    ws.Range("I2:L2").ClearContents
    PersistReplyReset ws, attemptId, state, closedAt
End Sub

Sub VerifyQueuedReplyPlan()
    With ThisWorkbook.Worksheets("ReplyPlan")
        Debug.Print "State=" & .Range("F2").Value2, "SourceIdentity=" & .Range("G2").Value2
        Debug.Print "AttemptID=" & .Range("I2").Value2, "Recipients=" & .Range("J2").Value2, "Digest=" & .Range("K2").Value2
        Debug.Print "Deferred=" & .Range("D2").Value2, "ResolutionApproval=" & .Range("L2").Value2
        Debug.Print "autoRetry=False", "saved=" & ThisWorkbook.Saved, "path=" & ThisWorkbook.Path
    End With
End Sub

選択0件・複数件、MailItem以外、返信先なしなら作らず、任意addressへ新規mailを送らない。選択メールへの承認済み遅延返信の結果が期待と違えば追加変更を重ねず、入力、対象範囲、locale・時刻、権限、製品仕様の順に戻って調べます。

Displayで宛先・引用を確認

外部自動返信loopや機密引用を防ぐため無条件Sendは行わず、ApprovedToQueueの一件を人が確認してからSendする。Displayで宛先・引用を確認に当てはまるときは中止理由、対象識別子、終了コードまたはErr.Number、直前に成功した段階を保存します。

選択0件・複数件、MailItem以外、返信先なしなら作らず、任意addressへ新規mailを送らない。選択メールへの承認済み遅延返信の再試行は原因を直し、同じ入力と対象を再確認してから行います。警告抑止や強制上書きで通しません。

過去時刻やmeeting itemで中止

QueueCancelledならplan statusをCancelledへする。Queued後は取り消せないため送信済みitemを照合する。復元にも「original EntryID、conversation ID、reply recipient、future time、plan rowを返信requestにする」を用い、類似名の別対象へ処理しません。

  • 選択メールへの承認済み遅延返信の開始前状態
  • 採用対象: original EntryID、conversation ID、reply recipient、future time、plan rowを返信requestにする
  • 復元後の確認: 元Conversationを引き継ぐreplyを一つSendし、宛先、引用、future時刻、Queued状態がplanと一致する
  • 復元を止める条件: 外部自動返信loopや機密引用を防ぐため無条件Sendは行わず、ApprovedToQueueの一件を人が確認してからSendする

未送信draftを取消

大量返信や不在通知はExchange/Outlook rule policyで管理し、このmacroをloop処理へ拡大しない。選択メールへの承認済み遅延返信を反復するときは、正常、差分なし、対象なし、要承認、失敗を別の状態として記録します。

未送信draftを取消の主キーoriginal EntryID、conversation ID、reply recipient、future time、plan rowを返信requestにする
採用条件元Conversationを引き継ぐreplyを一つSendし、宛先、引用、future時刻、Queued状態がplanと一致する
空結果選択0件・複数件、MailItem以外、返信先なしなら作らず、任意addressへ新規mailを送らない
中止条件外部自動返信loopや機密引用を防ぐため無条件Sendは行わず、ApprovedToQueueの一件を人が確認してからSendする

質問：不在応答との違い

Q. 選択メールへの承認済み遅延返信は管理者権限なら無条件に実行できますか。A. いいえ。MailItem.Replyは元mailに対応する返信itemを作り、DeferredDeliveryTimeは将来配信時刻を設定する。Outlook Ruleや不在応答とは別で、一件の選択mailに対する予約送信itemである。権限は入力や対象の妥当性を保証しません。

Q. 差分がなければ失敗ですか。A. 選択0件・複数件、MailItem以外、返信先なしなら作らず、任意addressへ新規mailを送らない。要件どおりの状態なら変更不要を正常として、検出不能とは区別します。

auto-reply ruleと一回返信を区別から証跡化するReplyでthreadを維持

選択メールへの承認済み遅延返信の証跡は「original EntryID、conversation ID、reply recipient、future time、plan rowを返信requestにする」を主キーにします。auto-reply ruleと一回返信を区別で確認した値と、実行直前・実行直後の値を同じ作業番号に保存し、表示名が似ている別対象や前回の結果を混ぜません。

選択MailItemを一件だけ確認で空結果を判定するfuture DeferredDeliveryTimeを設定

選択メールへの承認済み遅延返信の空結果は「選択0件・複数件、MailItem以外、返信先なしなら作らず、任意addressへ新規mailを送らない」として扱います。選択MailItemを一件だけ確認で入力自体が存在するか、権限で見えていないか、条件に一致しないだけかを分け、0件という表示だけで成功・失敗を決めません。

質問：不在応答との違いから復旧可否を測るauto-reply ruleと一回返信を区別

選択メールへの承認済み遅延返信の復旧判断では「QueueCancelledならplan statusをCancelledへする。Queued後は取り消せないため送信済みitemを照合する」を採用します。質問：不在応答との違いを再確認し、復旧後に「元Conversationを引き継ぐreplyを一つSendし、宛先、引用、future時刻、Queued状態がplanと一致する」へ戻ったかを別の読み取り処理で測定します。

選択メールへの承認済み遅延返信の事前確認では、original EntryID、conversation ID、reply recipient、future time、plan rowを返信requestにするを画面表示や標準出力だけで済ませず、実行日時と一緒に作業記録へ写します。MailItem.Replyは元mailに対応する返信itemを作り、DeferredDeliveryTimeは将来配信時刻を設定する。Outlook Ruleや不在応答とは別で、一件の選択mailに対する予約送信itemであるという仕様があるため、似た名前の別対象、前回実行時の値、キャッシュされた表示を今回の対象と取り違えないことが重要です。

選択メールへの承認済み遅延返信のコードを実行した直後は、まず終了状態を保存し、その後に別の読み取り処理で「元Conversationを引き継ぐreplyを一つSendし、宛先、引用、future時刻、Queued状態がplanと一致する」を確認します。選択メールへの承認済み遅延返信では同じコードの表示だけを合否判定に使うと部分成功や遅延反映を見逃すため、識別値、件数、内容の三点を照合します。

選択メールへの承認済み遅延返信で結果が得られない場合は、選択0件・複数件、MailItem以外、返信先なしなら作らず、任意addressへ新規mailを送らない。選択メールへの承認済み遅延返信ではこの状態と、権限拒否、入力形式の不一致、接続先や時刻の違いを一緒にしません。選択メールへの承認済み遅延返信の対象候補数、除外された候補、最後に成功した確認処理を残すと、再試行で同じ失敗を重ねずに済みます。

選択メールへの承認済み遅延返信を元へ戻す必要があるときは、QueueCancelledならplan statusをCancelledへする。Queued後は取り消せないため送信済みitemを照合する。選択メールへの承認済み遅延返信の復元前にも変更後の識別値を再取得し、別担当者の更新が入っていないか確認します。選択メールへの承認済み遅延返信の復元結果も通常処理と同じ完了条件で測り、戻したつもりという報告だけで閉じません。

選択メールへの承認済み遅延返信を引き継ぐ記録には、大量返信や不在通知はExchange/Outlook rule policyで管理し、このmacroをloop処理へ拡大しない。特に「外部自動返信loopや機密引用を防ぐため無条件Sendは行わず、ApprovedToQueueの一件を人が確認してからSendする」に該当した場合は、実行を止めたこと自体を正しい結果として扱います。選択メールへの承認済み遅延返信の次回担当者が承認範囲と未処理対象を区別できるよう、作業番号と対象識別子を対応付けます。

選択メールへの承認済み遅延返信の作業記録には、開始前の対象候補、採用した識別値、実行したコード、終了後の実測、除外理由を同じ作業番号で保存します。「original EntryID、conversation ID、reply recipient、future time、plan rowを返信requestにする」を省くと別対象との比較になり得るため、日時、実行場所、製品版と一緒に残します。

Excel VBAを利用したOutlookの自動返信スケジューリングの実装方法を定期運用へ組み込む場合も初回は対話的に確認します。正常は「元Conversationを引き継ぐreplyを一つSendし、宛先、引用、future時刻、Queued状態がplanと一致する」、空結果は「選択0件・複数件、MailItem以外、返信先なしなら作らず、任意addressへ新規mailを送らない」、停止は「外部自動返信loopや機密引用を防ぐため無条件Sendは行わず、ApprovedToQueueの一件を人が確認してからSendする」として報告し、次の担当者が同じ条件で追試できるようにします。

自動返信ルールではなく一件の予約返信として送る

選択中のMailItem一件とApprovedToQueue行を結び付け、Replyで作った返信へ未来のDeferredDeliveryTimeを設定します。ResolveAllと画面確認の後、Yesの場合だけSendし、元メールのEntryIDとQueued状態を記録します。

この例は受信メールすべてに反応する自動返信ルールではありません。同じEntryIDを再処理しない照合を運用側で行い、予定時刻後の配送結果は送信済みアイテムで別確認します。

クラッシュ・再起動の必須fault-injection fixture

Outbox fixture：Outlookをofflineにし、reply.Send直後かつQueuedのterminal save前にExcelを強制停止します。再起動後はQueueingまたはQueueUnknownとAttemptID・canonical SMTP tuple・DeferredDeliveryTime・message digestがdiskに残り、QueueApprovedDeferredReplyが拒否され、Outboxのexact 1件だけをQueuedへ保存すること、Send呼出し総数が1であることを確認します。Inspectorで件名・本文・宛先・時刻を変更したcaseはSend直前readbackで停止させます。

Sent・cardinality fixture：onlineでSent Itemsへ移動済みの1件、0件、複数件を別々に作ります。OutboxとSent Itemsの合計exact 1件だけをterminal化し、0件はQueueUnresolved、複数またはtuple不一致はQueueAmbiguousのまま自動再送しません。再試行する場合はL2へReapproveNoMatch:<AttemptID>または重複解消後のDuplicatesResolved:<AttemptID>を入れ、ResolveReplyAttemptForReapprovalで旧attemptをarchiveしてapprovalを空にし、新しいApprovedToQueueと新AttemptIDを要求します。実workbook/profileがない記事監査ではspecified-not-executedとして記録します。

公式情報・参考資料

選択メールへの遅延返信下書きのコマンド、API、対応範囲は次の公式一次資料で確認しました。確認日は2026年7月17日です。選択メールへの遅延返信下書きの実行環境にあるman、–help、VBA Object Browser、Get-Helpも併用してください。

VBA
スケジューリング コード Excel VBA Outlook メール 自動返信

この記事を書いた人

佐藤健司のアバター 佐藤健司

実務の現場で詰まりがちなポイントを地図にするITブログ「IT trip」を運営。Windows／Office（Teams・Excel）からSQL、サーバ運用、ガジェットまで、再現性のある手順と“なぜそうなるか”を丁寧に解説します。読んだらすぐ試せること、そして迷った人の次の一歩が見えることを大切にしています。

関連記事

コメント

コメントする

目次