从无法传递的电子邮件正文中提取文本字符串到excel [英] Extract text string from undeliverable email body to excel

问题描述

我需要有关Outlook VBA的帮助.

I need some help on Outlook VBA.

我正在尝试在Outlook中编写一个宏，用于从每个无法交付的电子邮件正文中提取电子邮件地址.

I am trying to write a macro in Outlook for extracting the email address from each individual undeliverables email body.

有数百封电子邮件发送失败，因此与自动复制和粘贴相比，自动提取它们会更好.

There are hundreds of emails failed for delivering, so it would be nicer if they could be extracted automatically than be copied and pasted manually.

电子邮件正文如下:

--------------------------------电子邮件------------------ ----------

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

向以下收件人或组的发送失败:

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

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

...不需要信息...

...no need info...

收件人:[e-mail]

To: [e-mail]

...不需要信息...

...no need info...

--------------------------------电子邮件------------------ -----------

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

我完全是Outlook VBA的新手，因此经过大量搜索和许多尝试之后，我终于想到了以下代码:

I am a completely Outlook VBA novice here, so after lots of searching and many trails I finally 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

它在我的测试电子邮件收件箱"中运行完美，该电子邮件收件箱打开了一个Excel工作表，并列出了目标电子邮件中的每个特定电子邮件地址.

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

但是，当我在工作电子邮件帐户上运行此代码时，它没有给我任何帮助.然后我发现它在阅读无法交付的邮件"时遇到了麻烦，而且奇怪的是，每次我运行它之后，其中一件无法交付的邮件变成了繁体中文字符，根本无法阅读.

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

像下面这样:

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

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

我觉得这段代码仅对转发的无法投递的电子邮件有效，在我的测试电子邮件收件箱中.但是，它从未读取过Microsoft Outlook发送的原始无法投递的电子邮件，并将这些电子邮件一一转换为汉字.

I am feeling like this code works on only forwarded undeliverable email, which in my test email inbox. But it never read from the original undeliverable emails which sent from Microsoft outlook and turned those emails to Chinese characters one by one.

我在Google上搜索了一下，看来它们是Outlook中一些失败的传递电子邮件的错误.你们中有人知道如何解决此问题吗?还是有什么方法可以改善我的代码?我愿意改变任何事情.

I googled about it, it seemed they're some bugs in Outlook for the failed delivery emails. Do any of you know how to fix this? Or is there any way to improve my code? I am open to changing anything.

推荐答案

经过几天的挫败，我终于提出了一个简单得多的解决方案，它无需担心Outlook中对NDR的任何限制，甚至不必使用VBA.根本...

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...

我所做的是:

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

不敢相信这比VBA更简单...

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

谢谢你们的帮助！只是无法真正解决在工作站上有如此多限制的"Outlook NDR变成无法读取的字符"的错误，认为这可能会有所帮助！

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屋！