MENU

Excel VBAを利用した「予約確認の自動メール送信」の方法と応用例

VBA

Excel VBAを利用した「予約確認の自動メール送信」の方法と応用例では、Reservations tableからApprovedToSendの一IDを取得し、未来日時と宛先を確認してOutlookから一件Sendする。Excel ListObjectは構造化tableのrowを扱える。予約IDを主キーにし、cell位置だけへ依存するとsort後に別予約を送る危険がある。この記事はreservation ID、recipient、reserved datetime、service、row statusを一件の通知requestにするを判断軸にして、記事固有のコード、合否、停止条件、復元を順序立てて説明します。

seq193の予約変更差分ではなく、確定した一予約の初回確認を扱う。完了は「件名・本文・宛先のreservation IDと日時がtable rowに一致し、statusがSubmittedへ一度だけ変わる」です。結果が空なら「ApprovedToSend 0件なら何も作らず、過去予約やcancelled rowを補正して送らない」として調べ、エラーを0件へ置き換えません。

目次

Reservations tableの列を固定

Reservations tableからApprovedToSendの一IDを取得し、未来日時と宛先を確認してOutlookから一件Sendする。承認済み予約確認メールの一件送信では、単にコマンドが終了したことではなく「件名・本文・宛先のreservation IDと日時がtable rowに一致し、statusがSubmittedへ一度だけ変わる」を完了条件にします。seq193の予約変更差分ではなく、確定した一予約の初回確認を扱う。

Reservations tableの列を固定に入る前に、対象、実行場所、権限、入力の由来を確認します。ApprovedToSend 0件なら何も作らず、過去予約やcancelled rowを補正して送らない。判定不能を成功へ丸めません。

reservation IDを主キーにする

reservation IDを主キーにするは変更や出力生成より先に行う観測です。reservation ID、recipient、reserved datetime、service、row statusを一件の通知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 Sub AssertRequiredReservationColumns(ByVal lo As ListObject)
    Dim ignored As Long, details As String
    On Error GoTo MissingColumn
    ignored = lo.ListColumns("ReservationID").Index
    ignored = lo.ListColumns("Email").Index
    ignored = lo.ListColumns("StartAt").Index
    ignored = lo.ListColumns("Status").Index
    ignored = lo.ListColumns("AttemptID").Index
    ignored = lo.ListColumns("ResolvedRecipients").Index
    ignored = lo.ListColumns("RequestedAt").Index
    ignored = lo.ListColumns("SubmittedAt").Index
    ignored = lo.ListColumns("ResolutionApproval").Index
    ignored = lo.ListColumns("ClosedAttemptID").Index
    ignored = lo.ListColumns("ClosedOutcome").Index
    ignored = lo.ListColumns("ClosedAt").Index
    Exit Sub
MissingColumn:
    details = CStr(Err.Number) & " " & Err.Description
    On Error GoTo 0
    Err.Raise vbObjectError + 1920, "AssertRequiredReservationColumns", "必要列がありません。送信しません: " & details
End Sub

Private Sub AssertUniqueReservationIds(ByVal lo As ListObject)
    Dim ids As Object, cell As Range, reservationId As String
    Set ids = CreateObject("Scripting.Dictionary")
    ids.CompareMode = vbTextCompare
    If lo.DataBodyRange Is Nothing Then Exit Sub
    For Each cell In lo.ListColumns("ReservationID").DataBodyRange.Cells
        reservationId = Trim$(CStr(cell.Value2))
        If Len(reservationId) = 0 Then Err.Raise 5, , "空のReservationIDがあります。状態は変更しません"
        If ids.Exists(reservationId) Then Err.Raise 5, , "重複ReservationIDがあります。送信せず状態も変更しません: " & reservationId
        ids.Add reservationId, cell.Row
    Next cell
End Sub

Private Function NewReservationAttemptId() 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"
    NewReservationAttemptId = "reservation-" & raw
    Exit Function
Failed:
    details = CStr(Err.Number) & " " & Err.Description
    On Error GoTo 0
    Err.Raise vbObjectError + 1921, "NewReservationAttemptId", "AttemptIDを生成できません。送信しません: " & details
End Function

Private Sub StampReservationAttempt(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 + 1927, "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 ReservationRowById(ByVal lo As ListObject, ByVal reservationId As String) As Range
    Dim ids As Range, hit As Range, rowIndex As Long
    Set ids = lo.ListColumns("ReservationID").DataBodyRange
    Set hit = ids.Find(What:=reservationId, After:=ids.Cells(ids.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
    If hit Is Nothing Then Err.Raise 5, , "ReservationIDを再取得できません: " & reservationId
    rowIndex = hit.Row - lo.DataBodyRange.Row + 1
    Set ReservationRowById = lo.ListRows(rowIndex).Range
End Function

Private Sub PersistReservationState(ByVal lo As ListObject, ByVal reservationId As String, ByVal expectedStatus As String, ByVal attemptId As String, ByVal expectedEmailInput As String, ByVal expectedRecipients As String, ByVal expectedStart As Date, ByVal expectedRequestedAt As Date, ByVal requireSubmittedAt As Boolean)
    Dim saveNumber As Long, saveDescription As String, rowRange As Range
    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 + 1922, "PersistReservationState", "ThisWorkbook.Save失敗: " & CStr(saveNumber) & " " & saveDescription
    If Not ThisWorkbook.Saved Then Err.Raise vbObjectError + 1923, "PersistReservationState", "Save後もThisWorkbook.Saved=Falseです"
    AssertUniqueReservationIds lo
    Set rowRange = ReservationRowById(lo, reservationId)
    If StrComp(CStr(rowRange.Cells(1, lo.ListColumns("Status").Index).Value2), expectedStatus, vbBinaryCompare) <> 0 Then Err.Raise 5, , "保存後Status再読不一致"
    If StrComp(CStr(rowRange.Cells(1, lo.ListColumns("AttemptID").Index).Value2), attemptId, vbBinaryCompare) <> 0 Then Err.Raise 5, , "保存後AttemptID再読不一致"
    If StrComp(Trim$(CStr(rowRange.Cells(1, lo.ListColumns("Email").Index).Value2)), expectedEmailInput, vbTextCompare) <> 0 Then Err.Raise 5, , "保存後Email入力再読不一致"
    If StrComp(CStr(rowRange.Cells(1, lo.ListColumns("ResolvedRecipients").Index).Value2), expectedRecipients, vbBinaryCompare) <> 0 Then Err.Raise 5, , "保存後canonical recipient tuple再読不一致"
    If Not IsDate(rowRange.Cells(1, lo.ListColumns("StartAt").Index).Value) Then Err.Raise 13, , "保存後StartAtがありません"
    If CDbl(CDate(rowRange.Cells(1, lo.ListColumns("StartAt").Index).Value)) <> CDbl(expectedStart) Then Err.Raise 5, , "保存後StartAt再読不一致"
    If Not IsDate(rowRange.Cells(1, lo.ListColumns("RequestedAt").Index).Value) Then Err.Raise 5, , "保存後RequestedAtがありません"
    If CDbl(CDate(rowRange.Cells(1, lo.ListColumns("RequestedAt").Index).Value)) <> CDbl(expectedRequestedAt) Then Err.Raise 5, , "保存後RequestedAt再読不一致"
    If requireSubmittedAt And Not IsDate(rowRange.Cells(1, lo.ListColumns("SubmittedAt").Index).Value) Then Err.Raise 5, , "保存後SubmittedAtがありません"
End Sub

Private Function CountReservationAttemptInFolder(ByVal folder As Object, ByVal attemptId As String, ByVal reservationId As String, ByVal expectedRecipients As String, ByVal expectedStart As Date, ByVal expectedRequestedAt As Date, ByRef mismatchCount As Long) As Long
    Dim item As Object, prop As Object, expectedSubject As String, expectedDateText As String
    expectedSubject = "予約確認 " & reservationId
    expectedDateText = Format$(expectedStart, "yyyy-mm-dd hh:nn")
    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
                    CountReservationAttemptInFolder = CountReservationAttemptInFolder + 1
                    Debug.Print "attemptMatch=" & attemptId, "folder=" & folder.FolderPath, "entry=" & item.EntryID
                    If StrComp(CanonicalRecipientTuple(item), expectedRecipients, vbBinaryCompare) <> 0 Then mismatchCount = mismatchCount + 1
                    If StrComp(CStr(item.Subject), expectedSubject, vbBinaryCompare) <> 0 Then mismatchCount = mismatchCount + 1
                    If InStr(1, CStr(item.Body), "予約ID: " & reservationId, vbBinaryCompare) = 0 Then mismatchCount = mismatchCount + 1
                    If InStr(1, CStr(item.Body), expectedDateText, vbBinaryCompare) = 0 Then mismatchCount = mismatchCount + 1
                    If Not IsDate(item.CreationTime) Then
                        mismatchCount = mismatchCount + 1
                    ElseIf Abs(DateDiff("s", CDate(item.CreationTime), expectedRequestedAt)) > 300 Then
                        mismatchCount = mismatchCount + 1
                    End If
                End If
            End If
        End If
    Next item
End Function

Private Sub PersistReservationReset(ByVal lo As ListObject, ByVal reservationId As String, ByVal closedAttemptId As String, ByVal closedOutcome As String, ByVal closedAt As Date)
    Dim saveNumber As Long, saveDescription As String, rowRange As Range
    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 + 1928, "PersistReservationReset", "ThisWorkbook.Save失敗: " & CStr(saveNumber) & " " & saveDescription
    If Not ThisWorkbook.Saved Then Err.Raise 5, , "reset Save後もThisWorkbook.Saved=Falseです"
    Set rowRange = ReservationRowById(lo, reservationId)
    If CStr(rowRange.Cells(1, lo.ListColumns("Status").Index).Value2) <> "NeedsReapproval" Then Err.Raise 5, , "reset後Status再読不一致"
    If Len(CStr(rowRange.Cells(1, lo.ListColumns("AttemptID").Index).Value2)) > 0 Or Len(CStr(rowRange.Cells(1, lo.ListColumns("ResolvedRecipients").Index).Value2)) > 0 Or Len(CStr(rowRange.Cells(1, lo.ListColumns("RequestedAt").Index).Value2)) > 0 Or Len(CStr(rowRange.Cells(1, lo.ListColumns("SubmittedAt").Index).Value2)) > 0 Or Len(CStr(rowRange.Cells(1, lo.ListColumns("ResolutionApproval").Index).Value2)) > 0 Then Err.Raise 5, , "reset後に旧attempt tupleまたはapprovalが残っています"
    If CStr(rowRange.Cells(1, lo.ListColumns("ClosedAttemptID").Index).Value2) <> closedAttemptId Or CStr(rowRange.Cells(1, lo.ListColumns("ClosedOutcome").Index).Value2) <> closedOutcome Then Err.Raise 5, , "closed attempt archive再読不一致"
    If Not IsDate(rowRange.Cells(1, lo.ListColumns("ClosedAt").Index).Value) Then Err.Raise 5, , "closedAtがありません"
    If CDbl(CDate(rowRange.Cells(1, lo.ListColumns("ClosedAt").Index).Value)) <> CDbl(closedAt) Then Err.Raise 5, , "closedAt再読不一致"
End Sub

Sub InspectReservationTable()
    Dim lo As ListObject, statusRange As Range
    Set lo = ThisWorkbook.Worksheets("Reservations").ListObjects("Reservations")
    AssertRequiredReservationColumns lo
    If lo.DataBodyRange Is Nothing Then Debug.Print "rows=0": Exit Sub
    AssertUniqueReservationIds lo
    Set statusRange = lo.ListColumns("Status").DataBodyRange
    Debug.Print "rows=" & lo.ListRows.Count, "idsUnique=True"
    Debug.Print "approved=" & Application.CountIf(statusRange, "ApprovedToSend"), "submitting=" & Application.CountIf(statusRange, "Submitting")
    Debug.Print "unknown=" & Application.CountIf(statusRange, "SendUnknown") + Application.CountIf(statusRange, "SendUnresolved") + Application.CountIf(statusRange, "SendAmbiguous")
    Debug.Print "reopenPolicy=inspect/reconcile only; no automatic Send"
End Sub

Excel ListObjectは構造化tableのrowを扱える。予約IDを主キーにし、cell位置だけへ依存するとsort後に別予約を送る危険がある。承認済み予約確認メールの一件送信では取得不能、対象なし、値が空という三状態を分け、stderrや終了コードを捨てません。

未来日時とrecipientを検証

未来日時とrecipientを検証ではReservations tableからApprovedToSendの一IDを取得し、未来日時と宛先を確認してOutlookから一件Sendする。承認済み予約確認メールの一件送信のサンプルにあるパス、セル、ユーザー、時刻は検証用なので、直前に確認した承認値へ置き換えます。

Sub SendNextApprovedReservationConfirmation()
    Dim lo As ListObject, statusCell As Range, rowRange As Range, rowIndex As Long, unsafeState As Variant, attemptProp As Object
    Dim reservationId As String, emailInput As String, resolvedRecipients As String, startsAt As Date, requestedAt As Date, attemptId As String
    Dim olApp As Object, mail As Object, failureText As String, persistText As String
    Set lo = ThisWorkbook.Worksheets("Reservations").ListObjects("Reservations")
    AssertRequiredReservationColumns lo
    If lo.DataBodyRange Is Nothing Then Exit Sub
    AssertUniqueReservationIds lo
    For Each unsafeState In Array("Submitting", "SendUnknown", "SendUnresolved", "SendAmbiguous")
        If Application.CountIf(lo.ListColumns("Status").DataBodyRange, CStr(unsafeState)) > 0 Then Err.Raise 5, , "結果未確定行を先に照合してください: " & CStr(unsafeState)
    Next unsafeState
    Set statusCell = lo.ListColumns("Status").DataBodyRange.Find(What:="ApprovedToSend", After:=lo.ListColumns("Status").DataBodyRange.Cells(lo.ListColumns("Status").DataBodyRange.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
    If statusCell Is Nothing Then Exit Sub
    rowIndex = statusCell.Row - lo.DataBodyRange.Row + 1
    Set rowRange = lo.ListRows(rowIndex).Range
    reservationId = Trim$(CStr(rowRange.Cells(1, lo.ListColumns("ReservationID").Index).Value2))
    emailInput = Trim$(CStr(rowRange.Cells(1, lo.ListColumns("Email").Index).Value2))
    If Not IsDate(rowRange.Cells(1, lo.ListColumns("StartAt").Index).Value) Then Err.Raise 13, , "StartAtが日付ではありません"
    startsAt = CDate(rowRange.Cells(1, lo.ListColumns("StartAt").Index).Value)
    If Len(emailInput) = 0 Or startsAt <= Now Then Err.Raise 5, , "予約行の必須値が不正です"
    If CStr(rowRange.Cells(1, lo.ListColumns("Status").Index).Value2) <> "ApprovedToSend" Then Err.Raise 5, , "状態が承認後に変わりました"
    If Len(CStr(rowRange.Cells(1, lo.ListColumns("AttemptID").Index).Value2)) > 0 Then Err.Raise 5, , "既存AttemptIDを明示reconcileしてください"
    If Len(CStr(rowRange.Cells(1, lo.ListColumns("ClosedAttemptID").Index).Value2)) > 0 And CStr(rowRange.Cells(1, lo.ListColumns("ResolutionApproval").Index).Value2) <> "ApprovedNewAttempt:" & reservationId Then Err.Raise 5, , "ResolutionApprovalへApprovedNewAttempt:<ReservationID>の明示再承認が必要です"
    attemptId = NewReservationAttemptId()
    requestedAt = Now
    Set olApp = CreateObject("Outlook.Application")
    Set mail = olApp.CreateItem(0)
    With mail
        .To = emailInput
        .Subject = "予約確認 " & reservationId
        .Body = "予約ID: " & reservationId & vbCrLf & "日時: " & Format$(startsAt, "yyyy-mm-dd hh:nn")
        If Not .Recipients.ResolveAll Then Err.Raise 5, , "予約者メールを解決できません"
    End With
    resolvedRecipients = CanonicalRecipientTuple(mail)
    StampReservationAttempt mail, attemptId
    rowRange.Cells(1, lo.ListColumns("Status").Index).Value2 = "Submitting"
    rowRange.Cells(1, lo.ListColumns("AttemptID").Index).Value2 = attemptId
    rowRange.Cells(1, lo.ListColumns("ResolvedRecipients").Index).Value2 = resolvedRecipients
    rowRange.Cells(1, lo.ListColumns("RequestedAt").Index).Value2 = requestedAt
    rowRange.Cells(1, lo.ListColumns("SubmittedAt").Index).ClearContents
    rowRange.Cells(1, lo.ListColumns("ResolutionApproval").Index).Value2 = "ConsumedApproval:" & attemptId
    PersistReservationState lo, reservationId, "Submitting", attemptId, emailInput, resolvedRecipients, startsAt, requestedAt, False
    On Error GoTo SendUnknown
    mail.Save
    Set attemptProp = mail.UserProperties.Find("ExcelAttemptID", True)
    If attemptProp Is Nothing Or CStr(attemptProp.Value) <> attemptId Then Err.Raise 5, , "保存draftのAttemptIDを再読できません"
    If CanonicalRecipientTuple(mail) <> resolvedRecipients Then Err.Raise 5, , "Send直前のcanonical recipient tupleが保存値と一致しません"
    mail.Send
    Set rowRange = ReservationRowById(lo, reservationId)
    rowRange.Cells(1, lo.ListColumns("Status").Index).Value2 = "Submitted"
    rowRange.Cells(1, lo.ListColumns("SubmittedAt").Index).Value2 = Now
    PersistReservationState lo, reservationId, "Submitted", attemptId, emailInput, resolvedRecipients, startsAt, requestedAt, True
    Exit Sub
SendUnknown:
    failureText = CStr(Err.Number) & " " & Err.Description
    On Error Resume Next
    Err.Clear
    Set rowRange = ReservationRowById(lo, reservationId)
    rowRange.Cells(1, lo.ListColumns("Status").Index).Value2 = "SendUnknown"
    PersistReservationState lo, reservationId, "SendUnknown", attemptId, emailInput, resolvedRecipients, startsAt, requestedAt, False
    If Err.Number <> 0 Then persistText = "; unknown-state save also failed: " & CStr(Err.Number) & " " & Err.Description
    On Error GoTo 0
    Err.Raise vbObjectError + 1924, "SendNextApprovedReservationConfirmation", "送信結果は未確定です。自動再送せずOutbox/SentをAttemptIDで照合します: " & failureText & persistText
End Sub

別予約の個人情報を差し込まない。ApprovedToSendを一件ずつSubmittingへ移してからResolveAllとSendを行う。承認済み予約確認メールの一件送信で変更が発生する場合は、新規出力、no-clobber、WhatIf、送信item表示など利用可能な安全機構を先に使います。

確認本文を一件生成

確認本文を一件生成では入力と出力を別々に再取得します。承認済み予約確認メールの一件送信の合格は、件名・本文・宛先のreservation IDと日時がtable rowに一致し、statusがSubmittedへ一度だけ変わることです。件数だけでなく識別値と内容も照合します。

Sub ReconcileNextReservationAttempt()
    Dim lo As ListObject, listRow As ListRow, rowRange As Range, state As String
    Dim reservationId As String, emailInput As String, resolvedRecipients As String, startsAt As Date, requestedAt As Date, attemptId As String
    Dim olApp As Object, session As Object, matchCount As Long, mismatchCount As Long
    Set lo = ThisWorkbook.Worksheets("Reservations").ListObjects("Reservations")
    AssertRequiredReservationColumns lo
    If lo.DataBodyRange Is Nothing Then Exit Sub
    AssertUniqueReservationIds lo
    For Each listRow In lo.ListRows
        state = CStr(listRow.Range.Cells(1, lo.ListColumns("Status").Index).Value2)
        Select Case state
            Case "Submitting", "SendUnknown", "SendUnresolved", "SendAmbiguous"
                Set rowRange = listRow.Range
                Exit For
        End Select
    Next listRow
    If rowRange Is Nothing Then Exit Sub
    reservationId = Trim$(CStr(rowRange.Cells(1, lo.ListColumns("ReservationID").Index).Value2))
    emailInput = Trim$(CStr(rowRange.Cells(1, lo.ListColumns("Email").Index).Value2))
    resolvedRecipients = CStr(rowRange.Cells(1, lo.ListColumns("ResolvedRecipients").Index).Value2)
    attemptId = CStr(rowRange.Cells(1, lo.ListColumns("AttemptID").Index).Value2)
    If Len(reservationId) = 0 Or Len(emailInput) = 0 Or Len(resolvedRecipients) = 0 Or Len(attemptId) = 0 Then Err.Raise 5, , "照合tupleが不足しています"
    If Not IsDate(rowRange.Cells(1, lo.ListColumns("StartAt").Index).Value) Then Err.Raise 13, , "StartAtがありません"
    If Not IsDate(rowRange.Cells(1, lo.ListColumns("RequestedAt").Index).Value) Then Err.Raise 13, , "RequestedAtがありません"
    startsAt = CDate(rowRange.Cells(1, lo.ListColumns("StartAt").Index).Value)
    requestedAt = CDate(rowRange.Cells(1, lo.ListColumns("RequestedAt").Index).Value)
    Set olApp = GetObject(, "Outlook.Application")
    Set session = olApp.Session
    matchCount = CountReservationAttemptInFolder(session.GetDefaultFolder(olFolderOutbox), attemptId, reservationId, resolvedRecipients, startsAt, requestedAt, mismatchCount)
    matchCount = matchCount + CountReservationAttemptInFolder(session.GetDefaultFolder(olFolderSentMail), attemptId, reservationId, resolvedRecipients, startsAt, requestedAt, mismatchCount)
    If mismatchCount > 0 Or matchCount > 1 Then
        rowRange.Cells(1, lo.ListColumns("Status").Index).Value2 = "SendAmbiguous"
        PersistReservationState lo, reservationId, "SendAmbiguous", attemptId, emailInput, resolvedRecipients, startsAt, requestedAt, False
        Err.Raise vbObjectError + 1925, "ReconcileNextReservationAttempt", "AttemptID一致が複数またはtuple不一致です。自動再送しません"
    ElseIf matchCount = 0 Then
        rowRange.Cells(1, lo.ListColumns("Status").Index).Value2 = "SendUnresolved"
        PersistReservationState lo, reservationId, "SendUnresolved", attemptId, emailInput, resolvedRecipients, startsAt, requestedAt, False
        Err.Raise vbObjectError + 1926, "ReconcileNextReservationAttempt", "Outbox/Sentに一致なしです。未送信と断定せず明示再承認まで停止します"
    Else
        rowRange.Cells(1, lo.ListColumns("Status").Index).Value2 = "Submitted"
        rowRange.Cells(1, lo.ListColumns("SubmittedAt").Index).Value2 = Now
        PersistReservationState lo, reservationId, "Submitted", attemptId, emailInput, resolvedRecipients, startsAt, requestedAt, True
    End If
End Sub

Sub ResolveReservationAttemptForReapproval()
    Dim lo As ListObject, listRow As ListRow, rowRange As Range, state As String
    Dim reservationId As String, attemptId As String, approval As String, closedAt As Date
    Set lo = ThisWorkbook.Worksheets("Reservations").ListObjects("Reservations")
    AssertRequiredReservationColumns lo
    If lo.DataBodyRange Is Nothing Then Exit Sub
    For Each listRow In lo.ListRows
        state = CStr(listRow.Range.Cells(1, lo.ListColumns("Status").Index).Value2)
        If state = "SendUnresolved" Or state = "SendAmbiguous" Then
            Set rowRange = listRow.Range
            Exit For
        End If
    Next listRow
    If rowRange Is Nothing Then Exit Sub
    reservationId = CStr(rowRange.Cells(1, lo.ListColumns("ReservationID").Index).Value2)
    attemptId = CStr(rowRange.Cells(1, lo.ListColumns("AttemptID").Index).Value2)
    approval = CStr(rowRange.Cells(1, lo.ListColumns("ResolutionApproval").Index).Value2)
    If state = "SendUnresolved" Then
        If Not IsDate(rowRange.Cells(1, lo.ListColumns("RequestedAt").Index).Value) Then Err.Raise 5, , "RequestedAtがありません"
        If Now <= CDate(rowRange.Cells(1, lo.ListColumns("RequestedAt").Index).Value) + TimeSerial(0, 10, 0) Then Err.Raise 5, , "RequestedAt後10分まではno-match再承認できません"
        If approval <> "ReapproveNoMatch:" & attemptId Then Err.Raise 5, , "ResolutionApprovalへReapproveNoMatch:<AttemptID>が必要です"
    Else
        If approval <> "DuplicatesResolved:" & attemptId Then Err.Raise 5, , "ResolutionApprovalへDuplicatesResolved:<AttemptID>が必要です"
    End If
    closedAt = Now
    rowRange.Cells(1, lo.ListColumns("ClosedAttemptID").Index).Value2 = attemptId
    rowRange.Cells(1, lo.ListColumns("ClosedOutcome").Index).Value2 = state
    rowRange.Cells(1, lo.ListColumns("ClosedAt").Index).Value2 = closedAt
    rowRange.Cells(1, lo.ListColumns("Status").Index).Value2 = "NeedsReapproval"
    rowRange.Cells(1, lo.ListColumns("AttemptID").Index).ClearContents
    rowRange.Cells(1, lo.ListColumns("ResolvedRecipients").Index).ClearContents
    rowRange.Cells(1, lo.ListColumns("RequestedAt").Index).ClearContents
    rowRange.Cells(1, lo.ListColumns("SubmittedAt").Index).ClearContents
    rowRange.Cells(1, lo.ListColumns("ResolutionApproval").Index).ClearContents
    PersistReservationReset lo, reservationId, attemptId, state, closedAt
End Sub

Sub VerifyReservationSendStates()
    Dim lo As ListObject
    Set lo = ThisWorkbook.Worksheets("Reservations").ListObjects("Reservations")
    AssertRequiredReservationColumns lo
    If lo.DataBodyRange Is Nothing Then Debug.Print "rows=0": Exit Sub
    AssertUniqueReservationIds lo
    Debug.Print "approved=" & Application.CountIf(lo.ListColumns("Status").DataBodyRange, "ApprovedToSend")
    Debug.Print "submitting=" & Application.CountIf(lo.ListColumns("Status").DataBodyRange, "Submitting")
    Debug.Print "submitted=" & Application.CountIf(lo.ListColumns("Status").DataBodyRange, "Submitted")
    Debug.Print "unknown=" & Application.CountIf(lo.ListColumns("Status").DataBodyRange, "SendUnknown") + Application.CountIf(lo.ListColumns("Status").DataBodyRange, "SendUnresolved") + Application.CountIf(lo.ListColumns("Status").DataBodyRange, "SendAmbiguous")
    Debug.Print "autoRetry=False", "saved=" & ThisWorkbook.Saved, "path=" & ThisWorkbook.Path
End Sub

ApprovedToSend 0件なら何も作らず、過去予約やcancelled rowを補正して送らない。承認済み予約確認メールの一件送信の結果が期待と違えば追加変更を重ねず、入力、対象範囲、locale・時刻、権限、製品仕様の順に戻って調べます。

OutlookでDisplayして人が確認

別予約の個人情報を差し込まない。ApprovedToSendを一件ずつSubmittingへ移してからResolveAllとSendを行う。OutlookでDisplayして人が確認に当てはまるときは中止理由、対象識別子、終了コードまたはErr.Number、直前に成功した段階を保存します。

ApprovedToSend 0件なら何も作らず、過去予約やcancelled rowを補正して送らない。承認済み予約確認メールの一件送信の再試行は原因を直し、同じ入力と対象を再確認してから行います。警告抑止や強制上書きで通しません。

ApprovedToSend以外や過去予約を除外

SendFailedで未送信と確認できたrowだけを承認後にApprovedToSendへ戻す。送信要求済みならSubmittedを維持する。復元にも「reservation ID、recipient、reserved datetime、service、row statusを一件の通知requestにする」を用い、類似名の別対象へ処理しません。

  • 承認済み予約確認メールの一件送信の開始前状態
  • 採用対象: reservation ID、recipient、reserved datetime、service、row statusを一件の通知requestにする
  • 復元後の確認: 件名・本文・宛先のreservation IDと日時がtable rowに一致し、statusがSubmittedへ一度だけ変わる
  • 復元を止める条件: 別予約の個人情報を差し込まない。ApprovedToSendを一件ずつSubmittingへ移してからResolveAllとSendを行う

Submittedへの一方向遷移

reservation ID、送信要求時刻、配送確認時刻を別fieldで持ち、SubmittedをDeliveredとしない。承認済み予約確認メールの一件送信を反復するときは、正常、差分なし、対象なし、要承認、失敗を別の状態として記録します。

Submittedへの一方向遷移の主キーreservation ID、recipient、reserved datetime、service、row statusを一件の通知requestにする
採用条件件名・本文・宛先のreservation IDと日時がtable rowに一致し、statusがSubmittedへ一度だけ変わる
空結果ApprovedToSend 0件なら何も作らず、過去予約やcancelled rowを補正して送らない
中止条件別予約の個人情報を差し込まない。ApprovedToSendを一件ずつSubmittingへ移してからResolveAllとSendを行う

質問：二重確認を防ぐ方法

Q. 承認済み予約確認メールの一件送信は管理者権限なら無条件に実行できますか。A. いいえ。Excel ListObjectは構造化tableのrowを扱える。予約IDを主キーにし、cell位置だけへ依存するとsort後に別予約を送る危険がある。権限は入力や対象の妥当性を保証しません。

Q. 差分がなければ失敗ですか。A. ApprovedToSend 0件なら何も作らず、過去予約やcancelled rowを補正して送らない。要件どおりの状態なら変更不要を正常として、検出不能とは区別します。

Reservations tableの列を固定から証跡化する未来日時とrecipientを検証

承認済み予約確認メールの一件送信の証跡は「reservation ID、recipient、reserved datetime、service、row statusを一件の通知requestにする」を主キーにします。Reservations tableの列を固定で確認した値と、実行直前・実行直後の値を同じ作業番号に保存し、表示名が似ている別対象や前回の結果を混ぜません。

reservation IDを主キーにするで空結果を判定する確認本文を一件生成

承認済み予約確認メールの一件送信の空結果は「ApprovedToSend 0件なら何も作らず、過去予約やcancelled rowを補正して送らない」として扱います。reservation IDを主キーにするで入力自体が存在するか、権限で見えていないか、条件に一致しないだけかを分け、0件という表示だけで成功・失敗を決めません。

質問：二重確認を防ぐ方法から復旧可否を測るReservations tableの列を固定

承認済み予約確認メールの一件送信の復旧判断では「SendFailedで未送信と確認できたrowだけを承認後にApprovedToSendへ戻す。送信要求済みならSubmittedを維持する」を採用します。質問：二重確認を防ぐ方法を再確認し、復旧後に「件名・本文・宛先のreservation IDと日時がtable rowに一致し、statusがSubmittedへ一度だけ変わる」へ戻ったかを別の読み取り処理で測定します。

承認済み予約確認メールの一件送信の事前確認では、reservation ID、recipient、reserved datetime、service、row statusを一件の通知requestにするを画面表示や標準出力だけで済ませず、実行日時と一緒に作業記録へ写します。Excel ListObjectは構造化tableのrowを扱える。予約IDを主キーにし、cell位置だけへ依存するとsort後に別予約を送る危険があるという仕様があるため、似た名前の別対象、前回実行時の値、キャッシュされた表示を今回の対象と取り違えないことが重要です。

承認済み予約確認メールの一件送信のコードを実行した直後は、まず終了状態を保存し、その後に別の読み取り処理で「件名・本文・宛先のreservation IDと日時がtable rowに一致し、statusがSubmittedへ一度だけ変わる」を確認します。承認済み予約確認メールの一件送信では同じコードの表示だけを合否判定に使うと部分成功や遅延反映を見逃すため、識別値、件数、内容の三点を照合します。

承認済み予約確認メールの一件送信で結果が得られない場合は、ApprovedToSend 0件なら何も作らず、過去予約やcancelled rowを補正して送らない。承認済み予約確認メールの一件送信ではこの状態と、権限拒否、入力形式の不一致、接続先や時刻の違いを一緒にしません。承認済み予約確認メールの一件送信の対象候補数、除外された候補、最後に成功した確認処理を残すと、再試行で同じ失敗を重ねずに済みます。

承認済み予約確認メールの一件送信を元へ戻す必要があるときは、SendFailedで未送信と確認できたrowだけを承認後にApprovedToSendへ戻す。送信要求済みならSubmittedを維持する。承認済み予約確認メールの一件送信の復元前にも変更後の識別値を再取得し、別担当者の更新が入っていないか確認します。承認済み予約確認メールの一件送信の復元結果も通常処理と同じ完了条件で測り、戻したつもりという報告だけで閉じません。

承認済み予約確認メールの一件送信を引き継ぐ記録には、reservation ID、送信要求時刻、配送確認時刻を別fieldで持ち、SubmittedをDeliveredとしない。特に「別予約の個人情報を差し込まない。ApprovedToSendを一件ずつSubmittingへ移してからResolveAllとSendを行う」に該当した場合は、実行を止めたこと自体を正しい結果として扱います。承認済み予約確認メールの一件送信の次回担当者が承認範囲と未処理対象を区別できるよう、作業番号と対象識別子を対応付けます。

承認済み予約確認メールの一件送信の作業記録には、開始前の対象候補、採用した識別値、実行したコード、終了後の実測、除外理由を同じ作業番号で保存します。「reservation ID、recipient、reserved datetime、service、row statusを一件の通知requestにする」を省くと別対象との比較になり得るため、日時、実行場所、製品版と一緒に残します。

Excel VBAを利用した「予約確認の自動メール送信」の方法と応用例を定期運用へ組み込む場合も初回は対話的に確認します。正常は「件名・本文・宛先のreservation IDと日時がtable rowに一致し、statusがSubmittedへ一度だけ変わる」、空結果は「ApprovedToSend 0件なら何も作らず、過去予約やcancelled rowを補正して送らない」、停止は「別予約の個人情報を差し込まない。ApprovedToSendを一件ずつSubmittingへ移してからResolveAllとSendを行う」として報告し、次の担当者が同じ条件で追試できるようにします。

承認状態を入力にして一行ずつ自動送信する

StatusがApprovedToSendの予約をFindで一行だけ取得し、必須値と未来日時を検証してからSubmittingへ先行遷移させます。ResolveAll後にSendを呼び、成功時はSubmitted、例外時はSendFailedを残します。Displayだけの送信item作成ではありません。

Submittingを先に書くことで同じ行を次回のFind対象から外します。停止後にSubmittingが残った場合はOutlookの送信済みアイテムを予約IDで照合し、未送信と確認できるまでApprovedToSendへ戻しません。

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

Outbox fixture：Reservations tableへAttemptID・ResolvedRecipients・RequestedAt・SubmittedAt・ResolutionApproval・ClosedAttemptID・ClosedOutcome・ClosedAt列を用意し、Outlookをofflineにしてmail.Send直後かつSubmitted save前にExcelを強制停止します。再起動後も対象行がSubmittingまたはSendUnknownで残り、全自動送信を停止し、canonical SMTP tuple・RequestedAtを含むOutboxのexact 1件だけをSubmittedへ保存すること、Send呼出し総数が1であることを確認します。

Sent・cardinality fixture：onlineのSent Items 1件、0件、複数件と、Sent Items ruleで移動中の状態を分けます。exact 1件だけをterminal化し、0件はSendUnresolved、複数またはtuple不一致はSendAmbiguousとします。再試行にはResolutionApprovalのReapproveNoMatch:<AttemptID>または重複解消後のDuplicatesResolved:<AttemptID>でResolveReservationAttemptForReapprovalを実行し、NeedsReapprovalへarchive後、ApprovedNewAttempt:<ReservationID>を伴う新承認と新AttemptIDを要求します。実workbook/profileがない記事監査ではspecified-not-executedとして記録します。

公式情報・参考資料

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

VBA
応用例 Excel VBA 自動メール送信 予約確認

この記事を書いた人

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

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

関連記事

コメント

コメントする

目次