从无法投递的电子邮件正文中提取文本字符串到excel

时间：2017-04-01 19:59:14

标签： excel vba email outlook outlook-vba

我在Outlook VBA上需要一些帮助。

我正在尝试在Outlook中编写一个宏，用于从每个不可更新的电子邮件正文中提取电子邮件地址。

有数百封电子邮件无法发送，因此如果可以自动提取它们而不是手动复制和粘贴它们会更好。

电子邮件正文如下：

  

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

     

向这些收件人或群组投放失败：

     

XXXX@XXXXXX.XXX（XXXX@XXXXXX.XXX）

     

......不需要信息......

     

收件人：XXXX@XXXXXX.XXX

     

......不需要信息......

     

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

我是一个完全是Outlook VBA的新手，所以经过大量的搜索和许多小道后，我终于想出了以下代码：

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工作表并列出了目标电子邮件中的每个特定电子邮件地址。

但是，当我在我的工作电子邮件帐户上运行此代码时，它并没有给我一些东西。然后我发现它在阅读“Undeliverables”电子邮件时遇到了麻烦，而且每次运行之后都会发生奇怪的事情，其中​​一个不可传递的电子邮件变成繁体中文字符，根本无法读取。

如下所示：

  

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

我觉得这段代码仅适用于转发无法投递的电子邮件，该电子邮件位于我的测试电子邮件收件箱中。但它从未从微软Outlook发送的原始无法投递的电子邮件中读取，并将这些电子邮件逐个转换为中文字符。

我用谷歌搜索了它，看起来他们在Outlook中发现了一些错误的发送电子邮件。你们中的任何人都知道如何解决这个问题吗？或者有什么方法可以改进我的代码吗？我愿意改变一切。

5 个答案:

答案 0 :(得分：0)

Outlook对象模型中的ReportItem.Body属性存在问题（2016年2016年的Outlook 2013中） - 您可以在OutlookSpy中看到它：选择NDR消息，单击项目按钮，选择Body属性 - 它将是乱码。更糟糕的是，一旦用OOM触摸报表项，Outlook将在预览窗格中显示相同的垃圾。

报告文本存储在各种MAPI收件人属性中（单击OutlookSpy中的IMessage按钮并转到GetRecipientTable选项卡）。问题是ReportItem对象不公开Recipients集合。解决方法是使用扩展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属性。

答案 1 :(得分：0)

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

我做的是：

  1. 选择Outlook中的所有未送达电子邮件
  2. 另存为“.txt”文件
  3. 打开Excel，打开txt文件并选择“Delimited”并在“文本导入向导”中选择“Tab”作为分隔符
  4. 使用“收件人：”过滤掉A列，然后获取B列
    5. 上的所有电子邮件地址

    无法相信这比VBA简单得多......

    谢谢你们的帮助！只是不能真正处理“Outlook NDR转向不可读的字符”的错误，因为工作站有这么多限制，认为这可能会有所帮助！

答案 2 :(得分：0)

要获取地址...我可以从action.reply中提取地址，该地址会创建带有正文和发件人的Outlook消息：

Sub Addressess_GET_for_all_selected()
   Dim objSel As Selection
   Dim i As Integer
   Dim objMail As MailItem
   Dim objRept As ReportItem
    Dim oa As Recipient
    Dim strStr As String
    Dim objAct As Action

   Set objSel = Outlook.ActiveExplorer.Selection

    Dim colAddrs As New Collection

    On Error GoTo 0
    frmProgress.SetMax (objSel.Count)
    'On Error Resume Next 'GoTo Set_Domains_Mail_Collection_ERR

    On Error GoTo SkipObj: ''for unhandled types
    For i = 1 To objSel.Count

      Set objMail = Nothing

      If objSel(i).Class = olReport Then    ''report email addresses 2020-02-12
         Set objRept = Nothing
         Set objRept = objSel(i)

         For Each objAct In objRept.Actions
            If objAct.Name = "Reply" Then
               Set objMail = objAct.Execute
               Exit For
            End If
         Next objAct
      End If

      ''fire on objmail or if is omail
      If objSel(i).Class = olMail Then
            Set objMail = objSel(i)
      End If

      If Not objMail Is Nothing Then
            DoEvents
            For Each oa In objMail.Recipients
                colAddrs.Add GetSMTPAddress(oa.Address)
            Next oa
            On Error Resume Next '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                colAddrs.Add GetSMTPAddress(objMail.sender.Address)
            On Error GoTo 0 '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
            objMail.Delete
      End If

SkipObj:
        frmProgress.SetCurrent (i)
    Next i

    SortDedupCollection_PUSH colAddrs
    frmProgress.Hide
End Sub

和GET SMTP：

Private Function GetSMTPAddress(ByVal strAddress As String) As String
' As supplied by Vikas Verma ... see
' http://blogs.msdn.com/vikas/archive/2007/10/24/oom-getting-primary-smtp-address-from-x400-x500-sip-ccmail-etc.aspx
Dim olApp As Object
Dim oCon As Object
Dim strKey As String
Dim oRec As Recipient ' Object
Dim strRet As String
Dim fldr As Object
    'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS
    On Error Resume Next

    If InStr(1, strAddress, "@", vbTextCompare) <> 0 Then
        GetSMTPAddress = strAddress
        Exit Function
    End If

    Set olApp = Application
    Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Item("Random")
    If fldr Is Nothing Then
        olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Add "Random"
        Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Item("Random")
    End If
    On Error GoTo 0
    If CInt(Left(olApp.VERSION, 2)) >= 12 Then
        Set oRec = olApp.Session.CreateRecipient(strAddress)
        If oRec.Resolve Then
            On Error Resume Next
            strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
            If strRet = "" Then
                strRet = Split(oRec.AddressEntry.Name, "(")(2) ''at least provide name.
                strRet = Left(strRet, InStr(1, strRet, ")") - 1)
            End If
            On Error GoTo 0
        End If
    End If
    If Not strRet = "" Then GoTo ReturnValue
    'IF OUTLOOK VERSION IS < 2007 THEN USES LITTLE HACK
    'How it works
    '============
    '1) It will create a new contact item
    '2) Set it's email address to the value passed by you, it could be X500,X400 or any type of email address stored in the AD
    '3) We will assign a random key to this contact item and save it in its Fullname to search it later
    '4) Next we will save it to local contacts folder
    '5) Outlook will try to resolve the email address & make AD call if required else take the Primary SMTP address from its cache and append it to Display name
    '6) The display name will be something like this " ( email.address@server.com )"
    '7) Now we need to parse the Display name and delete the contact from contacts folder
    '8) Once the contact is deleted it will go to Deleted Items folder, after searching the contact using the unique random key generated in step 3
    '9) We then need to delete it from Deleted Items folder as well, to clean all the traces
    Set oCon = fldr.items.Add(2)
    oCon.Email1Address = strAddress
    strKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
    oCon.FullName = strKey
    oCon.Save
    strRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), strKey, ""))
    oCon.Delete
    Set oCon = Nothing
    Set oCon = olApp.Session.GetDefaultFolder(3).items.Find("[Subject]=" & strKey)
    If Not oCon Is Nothing Then oCon.Delete
ReturnValue:
    GetSMTPAddress = strRet
End Function

答案 3 :(得分：0)

我一直遇到完全相同的问题。我正在处理的所有NDR消息都属于“ REPORT.IPM.Note.NDR”类，而我找到的用于获取原始收件人的方法是从许多此类帖子和问题中整理出来的拖网！

我正在对ReportItem使用PropertyAccessor.GetProperty方法，以从ReportItem的标题信息中获取PR_DISPLAY_TO属性值。

在VBA中，我使用MAPI namepace并遍历包含报告消息的给定文件夹的olItems集合。我正在Access中运行它，因为我的数据库前端是通过这种方式构建的，但是我想您可能可以在Outlook VBA中运行它（但不要束手无策）。

Dim olApp As Outlook.Application
Dim OlMapi As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.ReportItem
Dim OlItems As Outlook.Items

Set olApp = CreateObject("Outlook.Application")
Set OlMapi = olApp.GetNamespace("MAPI")
Set olFolder = OlMapi.Folders("SMTP-ADDRESS-FOR-YOUR-MAILBOX").Folders("Inbox").Folders("NAME-OF-SUBFOLDER_CONTAINING-NDR-REPORTS")
Set OlItems = olFolder.Items

If OlItem.Count > 0 Then
    For Each olMail In OlItems
        strEmail = olMail.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04001E")
        'DO WITH strEmail AS REQUIRED   
        DoEvents
    Next
End If

该MAPI属性返回的值可能是一个以分号分隔的列表，其中有多个收件人，因此您可以检查“;”在返回的字符串中，然后拆分为一个数组并进行迭代以获取每个地址，但是在我的情况下，只有一个接收者，因此我不需要使其过于复杂。 当原始收件人是联系人时，它也可能是显示名称，因此这对于某些人来说可能是一个缺点，但这又不是问题。

这只是更大功能的一小段，因此您将需要对其进行修改和集成，并且显然要替换或修改邮箱和子文件夹值的占位符。

当前的目的是还提取NDR原因代码，以便我可以自动从数据库中删除电子邮件地址，原因是因为该邮箱不存在，因此仅引用ReportItem对象-这可能行不通对于不属于该类型的NDR电子邮件，正如我想像的那样，MAPI属性不可用，但是实际上我发现，当我们使用Exchange Online时，所有NDR邮件都会像这样返回。

答案 4 :(得分：0)

我对第一篇文章中的原始代码做了一些调整， 并添加了一个辅助函数来从字符串中提取电子邮件，似乎运行良好。

Sub List_Undeliverable_Email_To_Excel()
    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).Folders("Real Estate").Folders("ag@joinreal.com")
    For Each myItem In myFolder.Items
        subjectOfEmail = myItem.Subject
        bodyOfEmail = myItem.Body
    
        'Search for Undeliverable email
        If subjectOfEmail Like "*Undeliverable*" Or subjectOfEmail Like "*Undelivered*" Or subjectOfEmail Like "*Failure*" And subjectOfEmail Like "*Delivery*" Then   'bodyOfEmail Like "*Deliver*" And
            x = x + 1
            'Extract email address from email body
            Lines = Split(bodyOfEmail, vbCrLf)
            For i = 0 To UBound(Lines)
                P = InStr(1, Lines(i), "@", vbTextCompare)
                If P > 0 Then
                    EmailAdd = ExtractEmailFromString(Lines(i), True)
                    Debug.Print x & " " & EmailAdd
                    xlApp.Range("A" & x) = EmailAdd
                    Exit For
                End If
            Next
        End If
    Next
End Sub

Function ExtractEmailFromString(extractStr As String, Optional OnlyFirst As Boolean) As String
    Dim CharList As String
    On Error Resume Next
    CheckStr = "[A-Za-z0-9._-]"
    OutStr = ""
    Index = 1
    Do While True
        Index1 = VBA.InStr(Index, extractStr, "@")
        getStr = ""
        If Index1 > 0 Then
            For P = Index1 - 1 To 1 Step -1
                If Mid(extractStr, P, 1) Like CheckStr Then
                    getStr = Mid(extractStr, P, 1) & getStr
                Else
                    Exit For
                End If
            Next
            getStr = getStr & "@"
            For P = Index1 + 1 To Len(extractStr)
                If Mid(extractStr, P, 1) Like CheckStr Then
                    getStr = getStr & Mid(extractStr, P, 1)
                Else
                    Exit For
                End If
            Next
            Index = Index1 + 1
            If OutStr = "" Then
                OutStr = getStr
                If OnlyFirst = True Then GoTo E
            Else
                OutStr = OutStr & Chr(10) & getStr
            End If
        Else
            Exit Do
        End If
    Loop
E:
    ExtractEmailFromString = OutStr
End Function

相关问题
最新问题