outlook电子邮件的收件人列表(收件人和抄送)

Question

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

现在它列出了：当前时间，保存电子邮件的Outlook文件夹，电子邮件类别，接收时间，发件人代码，发件人电子邮件，主题收件人；CC名称，附件，正文(纯文本(

我的问题是与To&抄送：我想得到电子邮件，而不是名字，就像我对Sender所做的那样，但还没能做到。有人能帮忙吗？

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

Option Explicit
Const TextFileNPath As String = "D:Email RegisterEmails.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"Register"；；200918-121900"TEST"发件人：[e-mail]"quot；RE：文献区1"致：史密斯；JOHN-CC:SANDERS；IRENA"收件人：无"嗨，约翰|布拉布拉"#2020-09-18 13:39:27#"Fldr:Inbox Eng"Register"；；200918-123900"ENTE"发件人：[e-mail]"quot；RE：文献区1"致：史密斯；约翰；'VICTOR MERS’-CC："收件人：Images/logos"布拉布拉"#2020-09-18 13:39:32#"Fldr：已发送"；；；200918-130800"DRAG"来自：Corp.JSMITH1"RE：区域1草案时间表"收件人："VICTOR MERS"；砂光机；伊雷娜；AINA NELSON-CC："收件人：Schedule_A v01.PDF；IMG_5989.jpg+IMG/Logo"布拉布拉">

所以我得到了：

"致：史密斯；JOHN-CC:SANDERS；IRENA"；

"致：史密斯；约翰；'VICTOR MERS’-CC："；

"收件人："VICTOR MERS"；砂光机；伊雷娜；AINA NELSON-CC："；

我想得到：

"收件人：[e-mail]-CC:[e-mail]">

"收件人：[e-mail]；[e-mail]-CC:"；

"收件人：[e-mail]；[e-mail]；[e-mail]-CC:"；

提前感谢您的帮助SAI-

Answer 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属性。