outlook マクロで送信前にアドレスチェックを行う

Option Explicit

' MAPI プロパティ
Private Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

' 送信ボタンイベント
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

On Error GoTo Exception

  Dim titleArr() As Variant
  
  Dim toAddress As Variant
  Dim ccAddress As Variant
  Dim bccAddress As Variant
  Dim AddressArray() As Variant
  
  Dim propAccessor As Variant
  Dim objRecipient As Recipient
  Dim name As String
  Dim subject As String
  Dim msg As String

  ' タイトル
  titleArr = Array("宛先", "CC", "BCC")
  
  ' 件名
  subject = Item.subject
  
  ' メッセージを作成
  msg = "件名" & subject & vbCrLf & "アドレスは間違いないですか" & vbCrLf & vbCrLf

  ' 全てのアドレスを取得
  For Each objRecipient In Item.Recipients
  
    Set propAccessor = objRecipient.PropertyAccessor

    With objRecipient
    
      name = .name & " <" & propAccessor.GetProperty(PR_SMTP_ADDRESS) & ">"
      
      If .Type = olTo Then
        toAddress = toAddress & name & ";"
      ElseIf .Type = olCC Then
        ccAddress = ccAddress & name & ";"
      Else
        bccAddress = bccAddress & name & ";"
      End If
      
    End With
    
  Next

  AddressArray = Array(toAddress, ccAddress, bccAddress)

  Dim i As Integer
  
  ' 最大インデックスを取得してタイトルごとのメッセージを作成
  For i = 0 To UBound(AddressArray)
    If Len(AddressArray(i)) = 0 Then AddressArray(i) = ";"
    AddressArray(i) = Split(Left(AddressArray(i), Len(AddressArray(i)) - 1), ";")
  Next i

  Dim j As Integer
  
  For i = 0 To UBound(AddressArray)
    msg = msg & titleArr(i) & vbCrLf
    For j = 0 To UBound(AddressArray(i))
      msg = msg & Trim(AddressArray(i)(j)) & vbCrLf
    Next j
  Next i

  If MsgBox(msg, vbYesNo + vbExclamation, "送信アドレスチェック") = vbNo Then
    Cancel = True
    Exit Sub
  End If

  
GoTo EXIT_SECTION
  
Exception:
    MsgBox CStr(Err.Number) & ":" & Err.Description, vbOKOnly + vbCritical
    Cancel = True
    Exit Sub
    GoTo EXIT_SECTION

EXIT_SECTION:

  Set Item = Nothing
  Set propAccessor = Nothing
  
End Sub