ExcelVBAでOutlookに着てるエラーメールのアドレスを取り出す。

大量の送信失敗が誰に届いていないのかを知りたいと要望があったのでVBAでリスト化しました。
とりあえず、適当なフォルダにエラーになってるメールをドラッグ＆ドロップで移します。

そしたらVBAで以下のコードを実行！！
「E:\メール*」の部分はメールをドラッグで持って行ったフォルダを指定

Sub メール解析()
Dim c As Range
Dim tmp As String

Dim OL As Object
Dim msg As Object

Dim re
Dim ptn As String
Dim mtc

Set c = ActiveSheet.Range("A1")
Set OL = CreateObject("Outlook.Application")

Set re = CreateObject("VBScript.RegExp")
ptn = "<(.+?)>:"
tmp = Dir("E:\メール\*")

Do While tmp <> ""
    Set msg = OL.CreateItemFromTemplate("E:\メール\" & tmp)
    
    c.Value = msg.Body
    
    
    With re
        .Pattern = ptn
        .IgnoreCase = True
        .Global = True
        
        'If .Test(msg.Body) Then c.Offset(0, 1).Value = 1
        
        Set mtc = .Execute(msg.Body)
        If mtc.Count > 0 Then
            c.Offset(0, 1).Value = mtc(0).Value
        End If
        
    End With
    
    Set c = c.Offset(1)
    tmp = Dir()
Loop

あとは、アクティブなシートに結果を書き出してくれます。

<メールアドレス>:

にしかマッチさせていないので他のパターンがあったら追加してください。