MENU

Excel VBAを利用した緊急連絡網のテストメール送信方法

VBA

Excel VBAを利用した緊急連絡網のテストメール送信方法では、ApprovedTestの一件だけMailItemを作り、TEST/NO ACTIONを明示してResolveAll成功後にDisplay確認してSendする。Recipients.ResolveAllはOutlook address bookに対して全recipientを解決できたか返す。解決成功は実際の配信や受領確認とは異なる。この記事はexercise ID、contact ID、resolved address、test ID、submission status、response statusを対応させるを判断軸にして、記事固有のコード、合否、停止条件、復元を順序立てて説明します。

通常予約通知ではなく、緊急連絡網の到達性を安全な訓練文面で確認する。完了は「正しいcontactへ一意なtest IDをSendし、Submitted状態、訓練表示、実対応不要が明確である」です。結果が空なら「対象contactやapprovalがなければ作らず、全連絡網へ範囲を拡大しない」として調べ、エラーを0件へ置き換えません。

目次

本番連絡とTESTを明確に分ける

ApprovedTestの一件だけMailItemを作り、TEST/NO ACTIONを明示してResolveAll成功後にDisplay確認してSendする。承認済み緊急連絡網テストメールでは、単にコマンドが終了したことではなく「正しいcontactへ一意なtest IDをSendし、Submitted状態、訓練表示、実対応不要が明確である」を完了条件にします。通常予約通知ではなく、緊急連絡網の到達性を安全な訓練文面で確認する。

本番連絡とTESTを明確に分けるに入る前に、対象、実行場所、権限、入力の由来を確認します。対象contactやapprovalがなければ作らず、全連絡網へ範囲を拡大しない。判定不能を成功へ丸めません。

contact IDと承認状態を確認

contact IDと承認状態を確認では「exercise ID、contact ID、resolved address、test ID、submission status、response statusを対応させる」という粒度で対象を特定します。Recipients.ResolveAllはOutlook address bookに対して全recipientを解決できたか返す。解決成功は実際の配信や受領確認とは異なる。表示名や先頭候補だけを採用しません。

承認済み緊急連絡網テストメールの対象が複数なら、候補数と除外理由を残します。承認済み緊急連絡網テストメールでは実行ユーザー、OS・製品版、locale、カレントディレクトリも結果の解釈へ影響するため同時に記録します。

Recipients.ResolveAllで宛先解決

Recipients.ResolveAllで宛先解決は変更や出力生成より先に行う観測です。exercise ID、contact ID、resolved address、test ID、submission status、response statusを対応させるを含む形で現状を保存し、後段のコードが同じ対象へ向くか確認します。

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

Private Sub StampEmergencyAttempt(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 + 1906, "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 EmergencyMessageDigest(ByVal mail As Object, ByVal canonicalRecipients As String, ByVal testId As String) As String
    EmergencyMessageDigest = StableTextDigest(CStr(mail.Subject) & vbLf & CStr(mail.Body) & vbLf & canonicalRecipients & vbLf & testId)
End Function

Private Sub PersistEmergencyState(ByVal ws As Worksheet, ByVal expectedState As String, ByVal expectedTestId As String, ByVal expectedAttemptId As String, ByVal expectedRecipient As String, ByVal expectedRequestedAt As Date, ByVal expectedDigest As String)
    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 + 1901, "PersistEmergencyState", "ThisWorkbook.Save失敗: " & CStr(saveNumber) & " " & saveDescription
    If Not ThisWorkbook.Saved Then Err.Raise vbObjectError + 1902, "PersistEmergencyState", "Save後もThisWorkbook.Saved=Falseです"
    If StrComp(CStr(ws.Range("G2").Value2), expectedState, vbBinaryCompare) <> 0 Then Err.Raise 5, , "保存後state再読不一致"
    If StrComp(CStr(ws.Range("H2").Value2), expectedTestId, vbBinaryCompare) <> 0 Then Err.Raise 5, , "保存後TestID再読不一致"
    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 Not IsDate(ws.Range("K2").Value) Then Err.Raise 5, , "保存後RequestedAtがありません"
    If CDbl(CDate(ws.Range("K2").Value)) <> CDbl(expectedRequestedAt) Then Err.Raise 5, , "保存後RequestedAt再読不一致"
    If StrComp(CStr(ws.Range("L2").Value2), expectedDigest, vbBinaryCompare) <> 0 Then Err.Raise 5, , "保存後message digest再読不一致"
    If CStr(ws.Range("F2").Value2) <> "ApprovedTest:" & expectedTestId Then Err.Raise 5, , "保存後approval再読不一致"
End Sub

Private Function CountEmergencyAttemptInFolder(ByVal folder As Object, ByVal attemptId As String, ByVal testId As String, ByVal expectedRecipient As String, ByVal expectedRequestedAt As Date, ByVal expectedDigest As String, ByRef mismatchCount As Long) As Long
    Dim item As Object, prop As Object, expectedSubject As String
    expectedSubject = "[TEST / NO ACTION] " & testId
    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
                    CountEmergencyAttemptInFolder = CountEmergencyAttemptInFolder + 1
                    Debug.Print "attemptMatch=" & attemptId, "folder=" & folder.FolderPath, "entry=" & item.EntryID
                    If StrComp(CanonicalRecipientTuple(item), expectedRecipient, vbBinaryCompare) <> 0 Then mismatchCount = mismatchCount + 1
                    If StrComp(CStr(item.Subject), expectedSubject, vbBinaryCompare) <> 0 Then mismatchCount = mismatchCount + 1
                    If StrComp(EmergencyMessageDigest(item, expectedRecipient, testId), expectedDigest, 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 PersistEmergencyReset(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 + 1907, "PersistEmergencyReset", "ThisWorkbook.Save失敗: " & CStr(saveNumber) & " " & saveDescription
    If Not ThisWorkbook.Saved Then Err.Raise 5, , "reset Save後もThisWorkbook.Saved=Falseです"
    If CStr(ws.Range("G2").Value2) <> "Ready" Then Err.Raise 5, , "reset後state再読不一致"
    If Len(CStr(ws.Range("F2").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 Or Len(CStr(ws.Range("M2").Value2)) > 0 Then Err.Raise 5, , "reset後に旧attempt tupleまたはapprovalが残っています"
    If CStr(ws.Range("N2").Value2) <> closedAttemptId Or CStr(ws.Range("O2").Value2) <> closedOutcome Then Err.Raise 5, , "closed attempt archive再読不一致"
    If Not IsDate(ws.Range("P2").Value) Then Err.Raise 5, , "closedAtがありません"
    If CDbl(CDate(ws.Range("P2").Value)) <> CDbl(closedAt) Then Err.Raise 5, , "closedAt再読不一致"
End Sub

Sub InspectEmergencyTestRow()
    With ThisWorkbook.Worksheets("EmergencyTest")
        Debug.Print "Scenario=" & .Range("A2").Value2, "Recipient=" & .Range("B2").Value2
        Debug.Print "Approval=" & .Range("F2").Value2, "State=" & .Range("G2").Value2, "TestID=" & .Range("H2").Value2
        Debug.Print "AttemptID=" & .Range("I2").Value2, "Recipients=" & .Range("J2").Value2, "RequestedAt=" & .Range("K2").Value2
        Debug.Print "Digest=" & .Range("L2").Value2, "ResolutionApproval=" & .Range("M2").Value2
        Debug.Print "reopenPolicy=inspect/reconcile only; no automatic Send"
    End With
End Sub

Recipients.ResolveAllはOutlook address bookに対して全recipientを解決できたか返す。解決成功は実際の配信や受領確認とは異なる。承認済み緊急連絡網テストメールでは取得不能、対象なし、値が空という三状態を分け、stderrや終了コードを捨てません。

一意なTest IDを件名へ付ける

一意なTest IDを件名へ付けるではApprovedTestの一件だけMailItemを作り、TEST/NO ACTIONを明示してResolveAll成功後にDisplay確認してSendする。承認済み緊急連絡網テストメールのサンプルにあるパス、セル、ユーザー、時刻は検証用なので、直前に確認した承認値へ置き換えます。

Sub SendApprovedEmergencyTest()
    Dim ws As Worksheet, olApp As Object, mail As Object, attemptProp As Object
    Dim testId As String, attemptId As String, expectedRecipient As String, expectedDigest As String, requestedAt As Date, answer As VbMsgBoxResult
    Dim failureText As String, persistText As String
    Set ws = ThisWorkbook.Worksheets("EmergencyTest")
    testId = Trim$(CStr(ws.Range("H2").Value2))
    If Len(testId) = 0 Or testId Like "*[!A-Za-z0-9_-]*" Then Err.Raise 5, , "immutable Test IDは英数字・_・-で明示します"
    If CStr(ws.Range("F2").Value2) <> "ApprovedTest:" & testId Then Err.Raise 5, , "承認をTest IDへbindしてください"
    If CStr(ws.Range("G2").Value2) <> "Ready" Or Len(CStr(ws.Range("I2").Value2)) > 0 Or Len(CStr(ws.Range("K2").Value2)) > 0 Or Len(CStr(ws.Range("L2").Value2)) > 0 Then Err.Raise 5, , "新しいReady requestだけを送信できます"
    If Len(Trim$(CStr(ws.Range("B2").Value2))) = 0 Then Err.Raise 5, , "訓練宛先が空です"
    attemptId = NewEmergencyAttemptId()
    Set olApp = CreateObject("Outlook.Application")
    Set mail = olApp.CreateItem(0)
    With mail
        .To = Trim$(CStr(ws.Range("B2").Value2))
        .Subject = "[TEST / NO ACTION] " & testId
        .Body = "これは訓練です。実対応は不要です。" & vbCrLf & "Test ID: " & testId
        If Not .Recipients.ResolveAll Then Err.Raise 5, , "訓練宛先を解決できません"
        .Display
    End With
    expectedRecipient = CanonicalRecipientTuple(mail)
    expectedDigest = EmergencyMessageDigest(mail, expectedRecipient, testId)
    answer = MsgBox("TEST表記・訓練宛先・immutable Test IDを確認し、この1通だけを送信しますか。", vbYesNo + vbExclamation, "訓練メール送信確認")
    If answer <> vbYes Then
        requestedAt = Now
        On Error Resume Next
        mail.Close olDiscard
        On Error GoTo 0
        ws.Range("G2").Value2 = "Cancelled"
        ws.Range("I2").Value2 = attemptId
        ws.Range("J2").Value2 = expectedRecipient
        ws.Range("K2").Value2 = requestedAt
        ws.Range("L2").Value2 = expectedDigest
        PersistEmergencyState ws, "Cancelled", testId, attemptId, expectedRecipient, requestedAt, expectedDigest
        Exit Sub
    End If
    If Not mail.Recipients.ResolveAll Then Err.Raise 5, , "最終確認後に訓練宛先を解決できません"
    If CStr(mail.Subject) <> "[TEST / NO ACTION] " & testId Then Err.Raise 5, , "Inspector確認後にTEST件名が変更されました"
    If InStr(1, CStr(mail.Body), "これは訓練です。実対応は不要です。", vbBinaryCompare) = 0 Or InStr(1, CStr(mail.Body), "Test ID: " & testId, vbBinaryCompare) = 0 Then Err.Raise 5, , "Inspector確認後に訓練本文またはTestIDが変更されました"
    expectedRecipient = CanonicalRecipientTuple(mail)
    requestedAt = Now
    expectedDigest = EmergencyMessageDigest(mail, expectedRecipient, testId)
    StampEmergencyAttempt mail, attemptId
    ws.Range("G2").Value2 = "Sending"
    ws.Range("I2").Value2 = attemptId
    ws.Range("J2").Value2 = expectedRecipient
    ws.Range("K2").Value2 = requestedAt
    ws.Range("L2").Value2 = expectedDigest
    PersistEmergencyState ws, "Sending", testId, attemptId, expectedRecipient, requestedAt, expectedDigest
    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) <> expectedRecipient Or EmergencyMessageDigest(mail, expectedRecipient, testId) <> expectedDigest Then Err.Raise 5, , "Send直前のrecipient/subject/body digestが保存tupleと一致しません"
    mail.Send
    ws.Range("G2").Value2 = "Submitted"
    PersistEmergencyState ws, "Submitted", testId, attemptId, expectedRecipient, requestedAt, expectedDigest
    Exit Sub
SendUnknown:
    failureText = CStr(Err.Number) & " " & Err.Description
    On Error Resume Next
    Err.Clear
    ws.Range("G2").Value2 = "SendUnknown"
    PersistEmergencyState ws, "SendUnknown", testId, attemptId, expectedRecipient, requestedAt, expectedDigest
    If Err.Number <> 0 Then persistText = "; unknown-state save also failed: " & CStr(Err.Number) & " " & Err.Description
    On Error GoTo 0
    Err.Raise vbObjectError + 1903, "SendApprovedEmergencyTest", "送信結果は未確定です。自動再送せずOutbox/SentをAttemptIDで照合します: " & failureText & persistText
End Sub

実際の緊急件名と混同させない。ApprovedTestの一件に限定し、訓練時間・recipient・内容を事前承認してSendする。承認済み緊急連絡網テストメールで変更が発生する場合は、新規出力、no-clobber、WhatIf、送信item表示など利用可能な安全機構を先に使います。

NO ACTION本文をDisplay

NO ACTION本文をDisplayでは入力と出力を別々に再取得します。承認済み緊急連絡網テストメールの合格は、正しいcontactへ一意なtest IDをSendし、Submitted状態、訓練表示、実対応不要が明確であることです。件数だけでなく識別値と内容も照合します。

Sub ReconcileEmergencyTestSubmission()
    Dim ws As Worksheet, olApp As Object, session As Object, state As String
    Dim testId As String, attemptId As String, expectedRecipient As String, expectedDigest As String, requestedAt As Date
    Dim matchCount As Long, mismatchCount As Long
    Set ws = ThisWorkbook.Worksheets("EmergencyTest")
    state = CStr(ws.Range("G2").Value2)
    Select Case state
        Case "Sending", "SendUnknown", "SendUnresolved", "SendAmbiguous"
        Case Else
            Err.Raise 5, , "照合対象のdurable send stateではありません"
    End Select
    testId = CStr(ws.Range("H2").Value2)
    attemptId = CStr(ws.Range("I2").Value2)
    expectedRecipient = CStr(ws.Range("J2").Value2)
    expectedDigest = CStr(ws.Range("L2").Value2)
    If Len(testId) = 0 Or Len(attemptId) = 0 Or Len(expectedRecipient) = 0 Or Len(expectedDigest) = 0 Or Not IsDate(ws.Range("K2").Value) Then Err.Raise 5, , "照合tupleが不足しています"
    requestedAt = CDate(ws.Range("K2").Value)
    Set olApp = GetObject(, "Outlook.Application")
    Set session = olApp.Session
    matchCount = CountEmergencyAttemptInFolder(session.GetDefaultFolder(olFolderOutbox), attemptId, testId, expectedRecipient, requestedAt, expectedDigest, mismatchCount)
    matchCount = matchCount + CountEmergencyAttemptInFolder(session.GetDefaultFolder(olFolderSentMail), attemptId, testId, expectedRecipient, requestedAt, expectedDigest, mismatchCount)
    If mismatchCount > 0 Or matchCount > 1 Then
        ws.Range("G2").Value2 = "SendAmbiguous"
        PersistEmergencyState ws, "SendAmbiguous", testId, attemptId, expectedRecipient, requestedAt, expectedDigest
        Err.Raise vbObjectError + 1904, "ReconcileEmergencyTestSubmission", "AttemptID一致が複数またはtuple不一致です。自動再送しません"
    ElseIf matchCount = 0 Then
        ws.Range("G2").Value2 = "SendUnresolved"
        PersistEmergencyState ws, "SendUnresolved", testId, attemptId, expectedRecipient, requestedAt, expectedDigest
        Err.Raise vbObjectError + 1905, "ReconcileEmergencyTestSubmission", "Outbox/Sentに一致なしです。未送信と断定せず明示再承認まで停止します"
    Else
        ws.Range("G2").Value2 = "Submitted"
        PersistEmergencyState ws, "Submitted", testId, attemptId, expectedRecipient, requestedAt, expectedDigest
    End If
End Sub

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

Sub VerifyEmergencyTestSubmission()
    With ThisWorkbook.Worksheets("EmergencyTest")
        Debug.Print "TestID=" & .Range("H2").Value2, "State=" & .Range("G2").Value2
        Debug.Print "AttemptID=" & .Range("I2").Value2, "Recipients=" & .Range("J2").Value2, "RequestedAt=" & .Range("K2").Value2
        Debug.Print "Digest=" & .Range("L2").Value2, "ResolutionApproval=" & .Range("M2").Value2
        Debug.Print "autoRetry=False", "saved=" & ThisWorkbook.Saved, "path=" & ThisWorkbook.Path
    End With
End Sub

対象contactやapprovalがなければ作らず、全連絡網へ範囲を拡大しない。承認済み緊急連絡網テストメールの結果が期待と違えば追加変更を重ねず、入力、対象範囲、locale・時刻、権限、製品仕様の順に戻って調べます。

未解決recipientで中止

実際の緊急件名と混同させない。ApprovedTestの一件に限定し、訓練時間・recipient・内容を事前承認してSendする。未解決recipientで中止に当てはまるときは中止理由、対象識別子、終了コードまたはErr.Number、直前に成功した段階を保存します。

対象contactやapprovalがなければ作らず、全連絡網へ範囲を拡大しない。承認済み緊急連絡網テストメールの再試行は原因を直し、同じ入力と対象を再確認してから行います。警告抑止や強制上書きで通しません。

受領結果を別表へ記録

配信、開封、返信を別statusで記録し、ResolveAllだけを連絡網テスト成功にしない。承認済み緊急連絡網テストメールを反復するときは、正常、差分なし、対象なし、要承認、失敗を別の状態として記録します。

受領結果を別表へ記録の主キーexercise ID、contact ID、resolved address、test ID、submission status、response statusを対応させる
採用条件正しいcontactへ一意なtest IDをSendし、Submitted状態、訓練表示、実対応不要が明確である
空結果対象contactやapprovalがなければ作らず、全連絡網へ範囲を拡大しない
中止条件実際の緊急件名と混同させない。ApprovedTestの一件に限定し、訓練時間・recipient・内容を事前承認してSendする

本番連絡とTESTを明確に分けるから証跡化するRecipients.ResolveAllで宛先解決

承認済み緊急連絡網テストメールの証跡は「exercise ID、contact ID、resolved address、test ID、submission status、response statusを対応させる」を主キーにします。本番連絡とTESTを明確に分けるで確認した値と、実行直前・実行直後の値を同じ作業番号に保存し、表示名が似ている別対象や前回の結果を混ぜません。

contact IDと承認状態を確認で空結果を判定する一意なTest IDを件名へ付ける

承認済み緊急連絡網テストメールの空結果は「対象contactやapprovalがなければ作らず、全連絡網へ範囲を拡大しない」として扱います。contact IDと承認状態を確認で入力自体が存在するか、権限で見えていないか、条件に一致しないだけかを分け、0件という表示だけで成功・失敗を決めません。

受領結果を別表へ記録から復旧可否を測る本番連絡とTESTを明確に分ける

承認済み緊急連絡網テストメールの復旧判断では「SendCancelledなら送信しない。Submitted後は撤回できないため誤送信手順を別に用意する」を採用します。受領結果を別表へ記録を再確認し、復旧後に「正しいcontactへ一意なtest IDをSendし、Submitted状態、訓練表示、実対応不要が明確である」へ戻ったかを別の読み取り処理で測定します。

承認済み緊急連絡網テストメールの事前確認では、exercise ID、contact ID、resolved address、test ID、submission status、response statusを対応させるを画面表示や標準出力だけで済ませず、実行日時と一緒に作業記録へ写します。Recipients.ResolveAllはOutlook address bookに対して全recipientを解決できたか返す。解決成功は実際の配信や受領確認とは異なるという仕様があるため、似た名前の別対象、前回実行時の値、キャッシュされた表示を今回の対象と取り違えないことが重要です。

承認済み緊急連絡網テストメールのコードを実行した直後は、まず終了状態を保存し、その後に別の読み取り処理で「正しいcontactへ一意なtest IDをSendし、Submitted状態、訓練表示、実対応不要が明確である」を確認します。承認済み緊急連絡網テストメールでは同じコードの表示だけを合否判定に使うと部分成功や遅延反映を見逃すため、識別値、件数、内容の三点を照合します。

承認済み緊急連絡網テストメールで結果が得られない場合は、対象contactやapprovalがなければ作らず、全連絡網へ範囲を拡大しない。承認済み緊急連絡網テストメールではこの状態と、権限拒否、入力形式の不一致、接続先や時刻の違いを一緒にしません。承認済み緊急連絡網テストメールの対象候補数、除外された候補、最後に成功した確認処理を残すと、再試行で同じ失敗を重ねずに済みます。

承認済み緊急連絡網テストメールを元へ戻す必要があるときは、SendCancelledなら送信しない。Submitted後は撤回できないため誤送信手順を別に用意する。承認済み緊急連絡網テストメールの復元前にも変更後の識別値を再取得し、別担当者の更新が入っていないか確認します。承認済み緊急連絡網テストメールの復元結果も通常処理と同じ完了条件で測り、戻したつもりという報告だけで閉じません。

承認済み緊急連絡網テストメールを引き継ぐ記録には、配信、開封、返信を別statusで記録し、ResolveAllだけを連絡網テスト成功にしない。特に「実際の緊急件名と混同させない。ApprovedTestの一件に限定し、訓練時間・recipient・内容を事前承認してSendする」に該当した場合は、実行を止めたこと自体を正しい結果として扱います。承認済み緊急連絡網テストメールの次回担当者が承認範囲と未処理対象を区別できるよう、作業番号と対象識別子を対応付けます。

承認済み緊急連絡網テストメールの作業記録には、開始前の対象候補、採用した識別値、実行したコード、終了後の実測、除外理由を同じ作業番号で保存します。「exercise ID、contact ID、resolved address、test ID、submission status、response statusを対応させる」を省くと別対象との比較になり得るため、日時、実行場所、製品版と一緒に残します。

Excel VBAを利用した緊急連絡網のテストメール送信方法を定期運用へ組み込む場合も初回は対話的に確認します。正常は「正しいcontactへ一意なtest IDをSendし、Submitted状態、訓練表示、実対応不要が明確である」、空結果は「対象contactやapprovalがなければ作らず、全連絡網へ範囲を拡大しない」、停止は「実際の緊急件名と混同させない。ApprovedTestの一件に限定し、訓練時間・recipient・内容を事前承認してSendする」として報告し、次の担当者が同じ条件で追試できるようにします。

訓練承認から一通だけSendする

F2がApprovedTestの行だけを対象にし、件名と本文へTEST/NO ACTIONと一意のTest IDを入れます。ResolveAll、Display、Yesの最終確認を通過した一通だけSendし、G2をSubmittedへ更新します。

Submittedは送信要求の記録であり、緊急連絡網が到達した証明ではありません。受信確認、配信不能、message trace、訓練参加者の応答はTest ID単位で別集計します。

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

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

Sent・cardinality fixture：onlineのSent Items 1件、0件、複数件を分け、OutboxとSent Itemsの合計exact 1件だけをterminal化します。0件はSendUnresolved、複数またはtuple不一致はSendAmbiguousのまま自動再送しません。再試行する場合はM2へReapproveNoMatch:<AttemptID>または重複解消後のDuplicatesResolved:<AttemptID>を入れ、ResolveEmergencyAttemptForReapprovalで旧attemptをarchiveしてApprovedTestを空にし、新承認と新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、サーバ運用、ガジェットまで、再現性のある手順と“なぜそうなるか”を丁寧に解説します。読んだらすぐ試せること、そして迷った人の次の一歩が見えることを大切にしています。

関連記事

コメント

コメントする

目次