将无法送达的电子邮件正文中的文本字符串提取到 Excel [英] Extract text string from undeliverable email body to Excel

问题描述

我正在尝试从每个无法送达的电子邮件正文中提取电子邮件地址.

电子邮件正文如下:

<块引用>

----------------------------邮箱------------------------------

<块引用>

向这些收件人或组发送失败:

<块引用>

[e-mail] ([e-mail])

<块引用>

...不需要信息...

<块引用>

收件人:[e-mail]

<块引用>

...不需要信息...

<块引用>

----------------------------邮箱-------------------------------

我想出了以下代码:

子测试()将 myFolder 调暗为 MAPIFolderDim Item As Outlook.MailItem 'MailItemDim xlApp 作为对象 'Excel.ApplicationDim xlWB 作为对象 'Excel.WorkbookDim xlSheet 作为对象 'Excel.WorksheetDim Lines() 作为字符串Dim i 为整数，x 为整数，P 为整数将 myItem 变暗为变体Dim subjectOfEmail As String将 bodyOfEmail 调暗为字符串'尝试访问excel出错时继续下一步Set xlApp = GetObject(, "Excel.Application")如果 xlApp 什么都没有，那么Set xlApp = CreateObject("Excel.Application")xlApp.Application.Visible = True如果 xlApp 什么都没有，那么MsgBox "Excel 不可访问";退出子万一万一出错时转到 0'添加一个新的工作簿设置 xlWB = xlApp.Workbooks.AddxlApp.Application.Visible = True设置 xlSheet = xlWB.ActiveSheet设置 myFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)对于 myFolder.Items 中的每个 myItemsubjectOfEmail = myItem.SubjectbodyOfEmail = myItem.Body'搜索无法送达的电子邮件如果 bodyOfEmail Like "*Delivery*";&*失败*"和 indexOfEmail 喜欢*无法投递*"；然后x = x + 1'从电子邮件正文中提取电子邮件地址Lines = Split(myItem.Body, vbCrLf)对于 i = 0 到 UBound(Lines)P = InStr(1, Lines(i), "@", vbTextCompare)Q = InStr(1, Lines(i), "(", vbTextCompare)如果 P >0 那么xlApp.Range("A" & x) = Trim$(Mid$(Lines(i), 1, Q - 1)) '提取电子邮件地址退出万一下一个万一下一个结束子

它适用于我的测试电子邮件收件箱，它打开了一个 Excel 表格并列出了目标电子邮件中的每个特定电子邮件地址.

当我在我的工作电子邮件帐户上运行此代码时，它没有给我任何东西.我发现阅读Undeliverables"有困难电子邮件，每次运行后，其中一封无法送达的电子邮件都变成了无法阅读的繁体中文字符.

<块引用>

格浴㹬格慥㹤਍洼瑥⁡瑨灴攭留癞∽潃瑮湥⵴祔数•潣瑮湥㹤琢硥⽴瑨汭汭※档我敳エ汆愥愥エ汆泷愥愥攞祤ാ㰊㹰戼㰾潦瑮挠汯牯∽〣〰㘰牧∶猠稳㵥㌢•慦散∽牁慩≬䐾汥癞牥潦楴⁥楴椥楴楴楴楴楴楴楴楴楴楴楴楴楴楴楴楴楴楴楴楴楴楴楴椥畯狞㰺是汤㹴⼼㹢⼼㹰਍昼汤⁴潣潬

我觉得此代码仅适用于在我的测试电子邮件收件箱中转发的无法送达的电子邮件.
它从不读取原始无法送达的电子邮件，并将这些电子邮件一一转换为汉字.

我用谷歌搜索了一下，Outlook 中似乎存在发送失败电子邮件的错误.如何解决这个问题?

解决方案

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

我所做的是:

1. 选择 Outlook 中所有未送达的电子邮件
2. 另存为.txt"文件
3. 打开Excel，打开txt文件，在文本导入向导"中选择分隔符"并选择制表符"作为分隔符
4. 用收件人:"过滤掉A列，然后将获得B列的所有电子邮件地址

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

谢谢大家的帮助！只是无法真正处理工作站上有这么多限制的Outlook NDR 转为不可读字符"的错误，认为这可能会有所帮助！

I am trying to extract the email address from each individual undeliverables email body.

The email body would be like:

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

Delivery has failed to these recipients or groups:

[e-mail] ([e-mail])

...no need info...

To: [e-mail]

...no need info...

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

I came up with below code:

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

It worked on my test Email Inbox, which opened an Excel sheet and listed every particular email address within the target emails.

When I ran this code on my work email account, it didn't give me a thing. I found that it had trouble reading "Undeliverables" emails, and every time after I ran it, one of the undeliverables emails turned into Traditional Chinese characters which cannot be read.

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

I feel this code works on only forwarded undeliverable email, in my test email inbox.
It never read from the original undeliverable emails and turned those emails to Chinese characters one by one.

I googled it, it seems there are bugs in Outlook for the failed delivery emails. How to fix this?

解决方案

After frustrated several days, I finally came up a much simpler solution, which doesn't need to worry about any restriction of NDR in Outlook or even never use VBA at all...

What I did is:

1. Select all the non-delivery emails in Outlook
2. Save as a ".txt" file
3. Open Excel, open the txt file and select "Delimited" and select "Tab" as delimiter in the "Text Import Wizard"
4. filter out the column A with "To:", then will get all the email address on column B

Can't believe this is much simpler than VBA...

Thank you guys for your help! Just can't really deal with the "Outlook NDR turning to unreadable characters" bug with so many restrictions on a work station, think this might be helpful!

这篇关于将无法送达的电子邮件正文中的文本字符串提取到 Excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！