【Outlook VBA】メール送信時に送信先確認ダイアログを表示する

Outlook（Microsoft 365）でメールを送信する時に、メールの宛先（CC、BCC）誤りを減らすためのマクロです。
送信ボタンを押したときに、送信先情報（送信先の表示名、メールアドレス）をダイアログで表示します。

送信先の表示名のみを表示する

ダイアログイメージ

ソースコード

Option Explicit

'Microsoft Outlook Objects > ThisOutlookSession に貼り付ける

'マクロのセキュリティ
' - 下記のどちらかを選択する
'   - すべてのマクロに対して警告を表示する
'   - すべてのマクロを有効にする（推奨しません。危険なコードが実行される可能性があります）

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

  Dim toList As Variant
  Dim ccList As Variant
  Dim bccList As Variant
  Dim msg As String

  toList = Item.To
  ccList = Item.CC
  bccList = Item.BCC

  toList = Split(toList, ";")
  ccList = Split(ccList, ";")
  bccList = Split(bccList, ";")

  msg = "下記の宛先(CC,BCC)にメールを送信します。よろしいですか？" & vbCrLf & vbCrLf

  Dim i As Integer

  msg = msg & "【宛先】" & vbCrLf
  For i = 0 To UBound(toList)
    msg = msg & "　[" & i + 1 & "] " & Trim(toList(i)) & vbCrLf
  Next i

  msg = msg & "【CC】" & vbCrLf
  For i = 0 To UBound(ccList)
    msg = msg & "　[" & i + 1 & "] " & Trim(ccList(i)) & vbCrLf
  Next i

  msg = msg & "【BCC】" & vbCrLf
  For i = 0 To UBound(bccList)
    msg = msg & "　[" & i + 1 & "] " & Trim(bccList(i)) & vbCrLf
  Next i

  If MsgBox(msg, vbYesNo + vbExclamation, "送信先確認") = vbNo Then
    Cancel = True
    Exit Sub
  End If

  Set Item = Nothing
End Sub

送信先の表示名とメールアドレスを表示する

ダイアログイメージ

ソースコード

Option Explicit

'Microsoft Outlook Objects > ThisOutlookSession に貼り付ける

'マクロのセキュリティ
' - 下記のどちらかを選択する
'   - すべてのマクロに対して警告を表示する
'   - すべてのマクロを有効にする（推奨しません。危険なコードが実行される可能性があります）

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

  Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

  Dim toList As Variant
  Dim ccList As Variant
  Dim bccList As Variant
  Dim toCcBccArray() As Variant
  Dim titleArray() As Variant
  Dim propAccessor As Variant
  Dim rcp As Recipient
  Dim name As String
  Dim msg As String

  titleArray = Array("【宛先】", "【CC】", "【BCC】")
  msg = "下記の宛先(CC,BCC)にメールを送信します。よろしいですか？" & vbCrLf & vbCrLf

  For Each rcp In Item.Recipients
    Set propAccessor = rcp.PropertyAccessor

    With rcp
      name = .name & " <" & propAccessor.GetProperty(PR_SMTP_ADDRESS) & ">"
      If .Type = olTo Then
        toList = toList & name & ";"
      ElseIf .Type = olCC Then
        ccList = ccList & name & ";"
      Else
        bccList = bccList & name & ";"
      End If
    End With
  Next

  toCcBccArray = Array(toList, ccList, bccList)

  Dim i As Integer
  For i = 0 To UBound(toCcBccArray)
    If Len(toCcBccArray(i)) = 0 Then toCcBccArray(i) = ";"
    toCcBccArray(i) = Split(Left(toCcBccArray(i), Len(toCcBccArray(i)) - 1), ";")
  Next i

  Dim j As Integer
  For i = 0 To UBound(toCcBccArray)
    msg = msg & titleArray(i) & vbCrLf
    For j = 0 To UBound(toCcBccArray(i))
      msg = msg & "　[" & j + 1 & "] " & Trim(toCcBccArray(i)(j)) & vbCrLf
    Next j
  Next i

  If MsgBox(msg, vbYesNo + vbExclamation, "送信先確認") = vbNo Then
    Cancel = True
    Exit Sub
  End If

  Set Item = Nothing
  Set propAccessor = Nothing
End Sub