excel - 从无法送达的电子邮件正文中提取文本字符串到 Excel

Question

我正在尝试从每个无法投递的电子邮件正文中提取电子邮件地址。
电子邮件正文如下:

----------------------------Email----------------------------

Delivery has failed to these recipients or groups:

XXXX@XXXXXX.XXX (XXXX@XXXXXX.XXX)

...no need info...

To: XXXX@XXXXXX.XXX

...no need info...

----------------------------Email-----------------------------

我想出了以下代码:

Sub Test()
   Dim myFolder As MAPIFolder
   Dim Item As Outlook.MailItem 'MailItem
   Dim xlApp As Object 'Excel.Application
   Dim xlWB As Object 'Excel.Workbook
   Dim xlSheet As Object 'Excel.Worksheet
   Dim Lines() As String
   Dim i As Integer, x As Integer, P As Integer
   Dim myItem As Variant
   Dim subjectOfEmail As String
   Dim bodyOfEmail As String

'Try access to excel
   On Error Resume Next
   Set xlApp = GetObject(, "Excel.Application")
   If xlApp Is Nothing Then
     Set xlApp = CreateObject("Excel.Application")
     xlApp.Application.Visible = True
     If xlApp Is Nothing Then
       MsgBox "Excel is not accessable"
       Exit Sub
     End If
   End If
   On Error GoTo 0

 'Add a new workbook
   Set xlWB = xlApp.Workbooks.Add
   xlApp.Application.Visible = True
   Set xlSheet = xlWB.ActiveSheet
   Set myFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
   For Each myItem In myFolder.Items
     subjectOfEmail = myItem.Subject
     bodyOfEmail = myItem.Body

 'Search for Undeliverable email
     If bodyOfEmail Like "*Delivery*" & "*failed*" And indexOfEmail Like "*Undeliverable*" Then
       x = x + 1
 'Extract email address from email body
       Lines = Split(myItem.Body, vbCrLf)
       For i = 0 To UBound(Lines)
         P = InStr(1, Lines(i), "@", vbTextCompare)
         Q = InStr(1, Lines(i), "(", vbTextCompare)
         If P > 0 Then
           xlApp.Range("A" & x) = Trim$(Mid$(Lines(i), 1, Q - 1)) 'extract the email address
           Exit For
         End If
       Next
    End If
  Next
End Sub

它适用于我的测试电子邮件收件箱，它打开了一个 Excel 表格并列出了目标电子邮件中的每个特定电子邮件地址。
当我在我的工作电子邮件帐户上运行此代码时，它并没有给我任何东西。我发现它无法阅读“无法投递”的邮件，每次运行后，其中一封无法投递的邮件变成了无法阅读的繁体汉字。

格浴㹬格慥㹤਍洼瑥⁡瑨灴攭畱癩∽潃瑮湥⵴祔数•潣瑮湥㵴琢硥⽴瑨汭※档牡敳㵴獵愭捳楩㸢⼼敨摡㰾潢祤ാ㰊㹰戼㰾潦瑮挠汯牯∽〣〰㘰∶猠穩㵥㌢•慦散∽牁慩≬䐾汥癩牥⁹慨⁳慦汩摥琠桴獥⁥敲楣楰湥獴漠⁲牧畯獰㰺是湯㹴⼼㹢⼼㹰਍昼湯⁴潣潬

我觉得此代码仅适用于在我的测试电子邮件收件箱中转发的无法投递的电子邮件。
它从不读取原始无法投递的电子邮件，并将这些电子邮件一一转换成汉字。
我用谷歌搜索了它，似乎 Outlook 中存在发送失败电子邮件的错误。如何解决这个问题？

Answer 1

折腾了几天后，我终于想出了一个更简单的解决方案，它不需要担心 Outlook 中 NDR 的任何限制，甚至根本不使用 VBA...

我所做的是:

选择 Outlook 中的所有未送达电子邮件

另存为“.txt”文件

打开Excel，打开txt文件，选择“Delimited”，在“Text Import Wizard”中选择“Tab”作为分隔符

用“收件人:”过滤掉A列，然后将得到B列上的所有电子邮件地址

不敢相信这比 VBA 简单得多......

谢谢你们的帮助!只是无法真正处理对工作站有如此多限制的“Outlook NDR 变为不可读字符”错误，认为这可能会有所帮助!