VBAでメール情報を取得する

Outlookにて、メールの新規作成 or 下書きをポップアップで開いるときに、
情報をチェックしたい。

Sub GetOpenMailInfo()
    Dim objInspector As Outlook.Inspector
    Dim objMail As Outlook.MailItem
    Dim recipients As Outlook.Recipients
    Dim recipient As Outlook.Recipient
    Dim attachment As Outlook.Attachment
    Dim recipientList As String
    Dim hasVoteButtons As Boolean
    Dim hasEncryption As Boolean

    ' 開いているメールアイテムを取得
    On Error Resume Next
    Set objInspector = Application.ActiveInspector
    If objInspector Is Nothing Then
        MsgBox "開いているメールがありません。"
        Exit Sub
    End If
    
    If objInspector.CurrentItem.Class = olMail Then
        Set objMail = objInspector.CurrentItem
    Else
        MsgBox "メールアイテムではありません。"
        Exit Sub
    End If
    On Error GoTo 0
    
    ' 差出人
    Dim sender As String
    If Not objMail.Sender Is Nothing Then
        sender = objMail.Sender.DisplayName
    Else
        sender = "情報なし"
    End If
    
    ' To, CC, BCC
    Set recipients = objMail.Recipients
    Dim toList As String, ccList As String, bccList As String
    toList = ""
    ccList = ""
    bccList = ""
    
    For Each recipient In recipients
        Select Case recipient.Type
            Case olTo
                toList = toList & recipient.Name & "; "
            Case olCC
                ccList = ccList & recipient.Name & "; "
            Case olBCC
                bccList = bccList & recipient.Name & "; "
        End Select
    Next recipient
    
    ' メール形式
    Dim format As String
    Select Case objMail.BodyFormat
        Case olFormatHTML
            format = "HTML"
        Case olFormatPlain
            format = "Plain Text"
        Case olFormatRichText
            format = "Rich Text"
        Case Else
            format = "Unknown"
    End Select
    
    ' 投票ボタンの有無
    hasVoteButtons = Not IsEmpty(objMail.VotingOptions)
    
    ' 暗号化の有無
    hasEncryption = objMail.Sensitivity = olConfidential
    
    ' 返信先設定
    Dim replyTo As String
    replyTo = objMail.ReplyRecipientNames
    
    ' 添付ファイルの有無
    Dim hasAttachments As Boolean
    hasAttachments = objMail.Attachments.Count > 0
    
    ' 結果を表示
    MsgBox "差出人: " & sender & vbCrLf & _
           "TO: " & toList & vbCrLf & _
           "CC: " & ccList & vbCrLf & _
           "BCC: " & bccList & vbCrLf & _
           "形式: " & format & vbCrLf & _
           "投票ボタン: " & IIf(hasVoteButtons, "あり", "なし") & vbCrLf & _
           "暗号化: " & IIf(hasEncryption, "あり", "なし") & vbCrLf & _
           "返信先: " & replyTo & vbCrLf & _
           "添付ファイル: " & IIf(hasAttachments, "あり", "なし")
End Sub