Outlook 电子邮件中的收件人列表（收件人和抄送）答案

【问题标题】：List of recipients (To and CC) from outlook emailOutlook 电子邮件中的收件人列表（收件人和抄送）
【发布时间】：2020-09-20 18:33:05
【问题描述】：

我有一个脚本，在 CSV 文件中列出了符合 Outlook 规则的电子邮件。

现在它列出：当前时间，保存电子邮件的 Outlook 文件夹，电子邮件类别，收到时间，发件人代码，发件人电子邮件，主题，收件人和抄送姓名，附件，正文（纯文本）

我的问题是 To & CC。我想获得电子邮件而不是名称，就像我对发件人所做的那样，但没有设法做到这一点。有人可以帮忙吗？

我在下面附上了我的代码和我得到的结果（以及我想要的结果）的示例。

Option Explicit
Const TextFileNPath As String = "D:\Email Register\Emails.txt"


Sub ListEmailsDataCSV(Item As Outlook.MailItem)

    Dim sReceived As String
    Dim sSubj As String
    Dim sSenderCode As String
    Dim sFrom As String
    Dim sTo As String
    Dim sCC As String
    Dim sAttach As String
    Dim sBody As String
    Dim sCategory As String
        
    Dim FF As Long
    Dim objAtt As Outlook.Attachment
    Dim fileEXT As String
    Dim bImages As Boolean
    Dim iCounter As Integer
    

ItemReceived:
    sReceived = Format$(Item.ReceivedTime, "yymmdd-hhnnss")
     
ItemSubject:

    sSubj = Item.Subject
    sSubj = CleanString(sSubj)
    
ItemFrom:

    sFrom = UCase(Item.SenderEmailAddress)
    
    If InStr(1, sFrom, "ADMINISTRATIVE GROUP") > 0 Then
        sSenderCode = "DRAG"
        sFrom = "Corp. " & Right(sFrom, Len(sFrom) - InStrRev(sFrom, "="))
        GoTo ItemTo
    Else
        sSenderCode = UCase(Mid(sFrom, InStr(1, sFrom, "@") + 1, 4))
    End If
    
ItemTo:

    sTo = CleanString(UCase(Item.To))

ItemCC:

    sCC = CleanString(UCase(Item.CC))

ItemAttach:

    iCounter = 0
    fileEXT = ""
    sAttach = "None"
    
    If Item.Attachments.Count = 0 Then GoTo ItemBody
    
    For Each objAtt In Item.Attachments

        fileEXT = UCase(Right(objAtt.FileName, 3))
        
        If InStr(1, UCase(objAtt.FileName), "IMAGE") > 0 Then
            If fileEXT = "JPG" Or fileEXT = "PNG" Or fileEXT = "GIF" Or fileEXT = "BMP" Then
                bImages = True
                GoTo NextAttach
            End If
        End If
   
        iCounter = iCounter + 1
   
        If iCounter = 1 Then
            sAttach = objAtt.FileName  'DisplayName
        Else
            sAttach = sAttach & "; " & objAtt.FileName  'DisplayName
        End If
        
NextAttach:

    Next objAtt
    
    If iCounter = 0 Then
        sAttach = "Images/logos"
    Else
        If bImages Then sAttach = sAttach & "; +Img/Logo"
    End If
    
    sAttach = CleanString(sAttach)
    
ItemBody:

    sBody = Item.Body
    sBody = CleanString(sBody)
CleanEntersBody:

    sBody = CleanDUPL(sBody)
    If InStr(1, sBody, "  ") > 0 Then GoTo CleanEntersBody
    If InStr(1, sBody, " |") > 0 Then GoTo CleanEntersBody
    If InStr(1, sBody, "||") > 0 Then GoTo CleanEntersBody

MailCategory:

    sCategory = Item.Categories

OutputFile:

    FF = FreeFile()
    Open TextFileNPath For Append As #FF

   'Write #FF, "Export Started", "Received", "Sender Code", "Subject", "Sender", "To", "CC", "Attachments", "Body"
    Write #FF, Now, "Fldr: " & Item.Parent, sCategory, sReceived, sSenderCode, "From: " & sFrom, sSubj, "To: " & sTo & " - CC: " & sCC, "Att: " & sAttach, sBody
    Close #FF

End Sub


Function CleanString(sString As String) As String
    sString = Replace(sString, Chr(10), "|") ' Char 10 = ENTER "new Line"
    sString = Replace(sString, Chr(13), "|") ' Char 13 = ENTER "Return" (a normal ENTER is Chr10 + Chr13)
    sString = Replace(sString, Chr(9), " ")  ' Char 9 = TAB
    
    sString = Replace(sString, Chr(34), "'")  ' Char 34 = "
    
    sString = Replace(sString, ",0", ".0")
    sString = Replace(sString, ",1", ".1")
    sString = Replace(sString, ",2", ".2")
    sString = Replace(sString, ",3", ".3")
    sString = Replace(sString, ",4", ".4")
    sString = Replace(sString, ",5", ".5")
    sString = Replace(sString, ",6", ".6")
    sString = Replace(sString, ",7", ".7")
    sString = Replace(sString, ",8", ".8")
    sString = Replace(sString, ",9", ".9")
    
    sString = Replace(sString, ",", ";")
    
    CleanString = sString
End Function

Function CleanDUPL(sString As String) As String 'used recursive to clean duplicates
    sString = Replace(sString, " |", "|")
    sString = Replace(sString, "||", "|")
    sString = Replace(sString, "  ", " ")
    CleanDUPL = sString
End Function

我得到的结果示例是：

#2020-09-18 13:39:27#;"Fldr: Inbox Eng";"Regist";200918-121900;"TEST";"From: VMERS@TESTCOMPANY.COM";"RE: 文档区1";"收件人：SMITH；JOHN - CC：SANDERS；IRENA"；"收件人：无"；"嗨，约翰；|Bla bla bla..." #2020-09-18 13:39:27#;"Fldr: Inbox Eng";"Regist";200918-123900;"ENTE";"From: IRENA@ENTERPRISE.COM";"RE: Documentation Area 1"; “致：SMITH；JOHN；'VICTOR MERS' - CC：”；“收件人：图片/徽标”；“Bla bla bla ...” #2020-09-18 13:39:32#;"Fldr: Sent";;200918-130800;"DRAG";"From: Corp. JSMITH1";"RE: Area 1 Draft Schedule";"To: 'VICTOR MERS'; SANDERS; IRENA; AINA NELSON - CC: ";"Att: Schedule_A v01.PDF; IMG_5989.jpg +Img/Logo";"Bla bla bla..."

所以我得到：

“致：SMITH；JOHN - CC：SANDERS；IRENA”

“致：SMITH；JOHN；'VICTOR MERS' - CC：”

“致：‘VICTOR MERS’；桑德斯；IRENA；艾娜·纳尔逊 - CC：”

我想得到：

“收件人：JSMITH1@MYCOMPANY.COM -抄送：IRENA@ENTERPRISE.COM”

“收件人：JSMITH1@MYCOMPANY.COM；VMERS@TESTCOMPANY.COM -抄送：”

“收件人：VMERS@TESTCOMPANY.COM；IRENA@ENTERPRISE.COM；A.NELSON@TESTCOMPANY.COM -抄送：”

提前感谢您的帮助总工程师

【问题讨论】：

标签： email outlook

【解决方案1】：

不要使用To/CC/BCC 属性，而是使用Recipients 集合，遍历所有收件人，然后为每个收件人读取Recipient.Name 和Recipient.Address 属性。要区分收件人类型，请检查Recipient.Type 属性（olTo / olCC / olBCC）。

请记住，对于 EX 收件人，您将获得 EX 类型的地址，而不是 SMTP。在这种情况下，您需要访问Recipient.AddressEntry.Type 属性，如果它是“EX”，请使用Recipient.AddressEntry.GetExchangeUser().PrimarySmtpAddress 属性。

【讨论】：