VBAで開封確認メールのメールアドレスを取得する方法

更新日：2023年12月5日

Excel VBAでOutlook.Applicationを使用し、シートにあるメールアドレスリストに対して、開封確認付きのメールを送信し、開封確認のメールが届いたら、メールアドレスリストにチェックをつけるというプログラムを作ることにしました。

開封確認のメールのメールを開くと、OutLookの画面上では送信元のメールアドレスが取得できるので、簡単にできるだろうとおもったらダメでした。
TypeName関数でメールオブジェクトのタイプを確認すると、MailItemではなくて、ReportItemとなっています。ReportItemの場合、送信元のメールアドレスを簡単に取得することができないようです。
PropertyAccessorを使い、proptag、0x007D001Eを指定することで、メールヘッダーを取得することができます。

以下のような形式でメールアドレスが記述されていたので、メールヘッダーの「From:」と「To:」の間からメールアドレスを抽出するという方法で取得しました。

From: =?iso-2022-jp?#####################=?=
<〇〇〇@xxx.xx>
To: =?iso-2022-jp?#####################=?=
<●●●@xxx.xx>

Sub 開封確認メールチェック()

    Dim olApp As Object
    Dim olNamespace As Object
    Dim olInbox As Object
    Dim olSubFolder As Object
    Dim olMail As Object
    Dim p As Object
    Dim sProperty As String
    Dim sEmail As String
    
    Set olApp = CreateObject("Outlook.Application")
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olInbox = olNamespace.GetDefaultFolder(6) '受信トレイ
    Set olSubFolder = olInbox.Folders("test")  '受信トレイの中のフォルダ名
    
    
    For Each olMail In olSubFolder.Items
        ' メールアイテムがReportItemオブジェクトであることを確認
        If TypeName(olMail) = "ReportItem" Then
        
            Set p = olMail.PropertyAccessor
            sEmail = ExtractEmailAddress(p.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E"))
            Debug.Print sEmail
        End If
    Next olMail

End Sub

Function ExtractEmailAddress(headers As String) As String
    Dim fromPos As Integer
    Dim toPos As Integer
    Dim headerPart As String
    Dim emailAddress As String

    ' From: から To: までの部分を抽出
    fromPos = InStr(headers, "From: ")
    toPos = InStr(fromPos, headers, "To: ")

    If fromPos > 0 And toPos > 0 Then
        headerPart = Mid(headers, fromPos, toPos - fromPos)

        ' メールアドレスを抽出
        emailAddress = ExtractEmail(headerPart)
        ExtractEmailAddress = emailAddress
    End If
End Function

Function ExtractEmail(text As String) As String
    Dim startPos As Integer
    Dim endPos As Integer
    Dim email As String

    startPos = InStr(text, "<")
    endPos = InStr(startPos, text, ">")

    If startPos > 0 And endPos > 0 Then
        email = Mid(text, startPos + 1, endPos - startPos - 1)
        ExtractEmail = email
    Else
        ExtractEmail = ""
    End If
End Function

Sub 開封確認メールチェック()

Dim olApp As Object

Dim olNamespace As Object

Dim olInbox As Object

Dim olSubFolder As Object

Dim olMail As Object

Dim p As Object

Dim sProperty As String

Dim sEmail As String

Set olApp = CreateObject("Outlook.Application")

Set olNamespace = olApp.GetNamespace("MAPI")

Set olInbox = olNamespace.GetDefaultFolder(6) '受信トレイ

Set olSubFolder = olInbox.Folders("test") '受信トレイの中のフォルダ名

For Each olMail In olSubFolder.Items

' メールアイテムがReportItemオブジェクトであることを確認

If TypeName(olMail) = "ReportItem" Then

Set p = olMail.PropertyAccessor

sEmail = ExtractEmailAddress(p.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E"))

Debug.Print sEmail

End If

Next olMail

End Sub

Function ExtractEmailAddress(headers As String) As String

Dim fromPos As Integer

Dim toPos As Integer

Dim headerPart As String

Dim emailAddress As String

' From: から To: までの部分を抽出

fromPos = InStr(headers, "From: ")

toPos = InStr(fromPos, headers, "To: ")

If fromPos > 0 And toPos > 0 Then

headerPart = Mid(headers, fromPos, toPos - fromPos)

' メールアドレスを抽出

emailAddress = ExtractEmail(headerPart)

ExtractEmailAddress = emailAddress

End If

End Function

Function ExtractEmail(text As String) As String

Dim startPos As Integer

Dim endPos As Integer

Dim email As String

startPos = InStr(text, "<")

endPos = InStr(startPos, text, ">")

If startPos > 0 And endPos > 0 Then

email = Mid(text, startPos + 1, endPos - startPos - 1)

ExtractEmail = email

Else

ExtractEmail = ""

End If

End Function