时间戳

首页 > 解决方案 > Outlook 电子邮件中的收件人列表（收件人和抄送）

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

问题描述

我有一个脚本，在 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: Documentation Area 1"; “收件人：史密斯；约翰 - 抄送：桑德斯；IRENA”；“联系人：无”；“嗨，约翰；|Bla bla bla ...”#2020-09-18 13:39:27#；“Fldr：收件箱 Eng ";"Regist";200918-123900;"ENTE";"发件人：IRENA@ENTERPRISE.COM";"RE：文档区 1";"收件人：SMITH；JOHN；'VICTOR MERS' - CC：";"Att : 图片/徽标";"Bla bla bla..." #2020-09-18 13:39:32#;"Fldr: Sent";;200918-130800;"DRAG";"From: Corp. JSMITH1"; “RE：Area 1 Draft Schedule”；“收件人：'VICTOR MERS'；SANDERS；IRENA；AINA NELSON - CC：”；“收件人：Schedule_A v01.PDF；IMG_5989.jpg +Img/Logo”；“呜呜呜……”

所以我得到：

“致：史密斯；约翰 - 抄送：桑德斯；IRENA”

“致：史密斯；约翰；‘维克多·梅尔斯’——抄送：”

“致：‘VICTOR MERS’；Sanders；IRENA；AINA NELSON - CC：”

我想得到：

“致：JSMITH1@MYCOMPANY.COM - 抄送：IRENA@ENTERPRISE.COM”

“致：JSMITH1@MYCOMPANY.COM；VMERS@TESTCOMPANY.COM - 抄送：”

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

在此先感谢您的帮助 SAI

标签： emailoutlook

解决方案

而不是使用To//属性，而是使用CC集合，遍历所有收件人，并为每个收件人读取和属性。要区分收件人类型，请检查属性 ( / / )。BCCRecipientsRecipient.NameRecipient.AddressRecipient.TypeolToolCColBCC

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

推荐阅读