将无法传送的电子邮件正文中的文本string提取为excel
我需要Outlook VBA上的一些帮助。
我正在尝试在Outlook中编写一个macros，用于从每个单独的无法传送的邮件正文中提取电子邮件地址。
有数以百计的电子邮件传递失败，所以它会更好，如果他们可以自动提取比手动复制和粘贴。
电子邮件正文如下所示：
– – – – – – – – – – – – – – 电子邮件 – – – – – – – – – – – ——-
无法发送至对方或群组：
XXXX@XXXXXX.XXX（XXXX@XXXXXX.XXX）
…不需要信息…
致：XXXX@XXXXXX.XXX
…不需要信息…
– – – – – – – – – – – – – – 电子邮件 – – – – – – – – – – – ——–
我在这里是一个完全的Outlook VBA新手，所以经过大量的search和很多的追踪，我终于find了下面的代码：
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 它在我的testing电子邮件收件箱中工作得很好，它打开了一个Excel工作表，并列出了目标电子邮件中的每个特定电子邮件地址。
但是，当我在我的工作电子邮件帐户上运行此代码时，它并没有给我一个东西。 然后我发现阅读“无法发送的”邮件时遇到了麻烦，奇怪的是每次运行之后，其中一个无法发送的邮件就变成了繁体字，根本看不到。
如下所示：
格浴㹬格慥㹤洼瑥瑨灴攭留癞∽潃瑮湥祔数•潣瑮湥㵴琢硥⽴瑨汭※档牡敳㵴猎愭捳楩㸢⼼敨摡㰾潢祤ാ㰊㹰戼㰾潦瑮挠汯牯∽〣〰㘰：猠稳㵥㌢•慦散∽牁慩≬䐾汥癞牥⁹慨慦汩摥琠桴獥敲楣楰湥獴漠牧畯狞㰺是汤㹴⼼㹢⼼㹰昼汤⁴潣潬
我感觉就像这个代码工作只转发无法投递的电子邮件，在我的testing电子邮件收件箱。 但是它从来没有从微软Outlook发送的原始无法投递的电子邮件中读取，并将这些电子邮件逐一转换为中文字符。
我search了一下，似乎他们在Outlook中的一些错误的邮件失败。 你们有没有人知道如何解决这个问题？ 或者有什么办法来改善我的代码？ 我愿意改变任何事情。
经过几天的沮丧，我终于想出了一个更简单的解决scheme，不需要担心在Outlook中对NDR的任何限制，甚至从不使用VBA。
我所做的是：
- 在Outlook中select所有未送达的电子邮件
- 保存为“.txt”文件
- 打开Excel，打开txt文件并select“Delimited”并在“Text Import Wizard”中select“Tab”作为分隔符
- 用“To：”过滤掉A列，然后得到B列的所有电子邮件地址
不能相信这比VBA简单得多…
谢谢你们的帮助！ 只是不能真正处理“Outlook NDR转向不可读的字符”的bug，在工作站上有这么多的限制，认为这可能是有帮助的！
Outlook对象模型中的ReportItem.Body属性存在问题（在Outlook 2013 abd 2016中存在） – 您可以在OutlookSpy中看到它：select一个NDR消息，单击项目button，select正文属性 – 它将会出现乱码。 更糟糕的是，一旦报表项目被OOM触及，Outlook将在预览窗格中显示相同的垃圾。
报告文本存储在各种MAPI收件人属性中（单击OutlookSpy中的IMessagebutton并转到GetRecipientTable选项卡）。 问题是ReportItem对象不公开收件人集合。 解决方法是使用扩展MAPI（C ++或Delphi）或Redemption （任何语言） – 其RDOReportItem .ReportText属性不具有此问题：
set oItem = Application.ActiveExplorer.Selection(1) set oSession = CreateObject("Redemption.RDOSession") oSession.MAPIOBJECT = Application.Session.MAPIOBJECT set rItem = oSession.GetRDOObjectFromOutlookObject(oItem) MsgBox rItem.ReportText
您还可以使用RDOReportItem.Recipients集合从收件人表中提取各种NDR属性。