List of recipients (To and CC) from outlook email - email

Question

I have an script that lists in a CSV file the emails complying with an outlook rule.
Right now it lists:
Current Time,
Outlook folder where email is saved,
Email Category,
Received Time,
Sender Code,
sender Email,
Subject,
To & CC Names,
Attachments,
Body (Plain Text)
My issue is with To & CC. I would like to get the emails rather than the names, like I do with Sender, but have not managed to do it.
Anyone can help?
I attach my code and an example of the results I get (and what I wanted) below.
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
And a sample of the results I am getting is:
#2020-09-18 13:39:27#;"Fldr: Inbox Eng";"Regist";200918-121900;"TEST";"From: VMERS#TESTCOMPANY.COM";"RE: Documentation Area 1";"To: SMITH; JOHN - CC: SANDERS; IRENA";"Att: None";"Hi John;|Bla bla bla..."
#2020-09-18 13:39:27#;"Fldr: Inbox Eng";"Regist";200918-123900;"ENTE";"From: IRENA#ENTERPRISE.COM";"RE: Documentation Area 1";"To: SMITH; JOHN; 'VICTOR MERS' - CC: ";"Att: Images/logos";"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..."
So I am getting:
"To: SMITH; JOHN - CC: SANDERS; IRENA"
"To: SMITH; JOHN; 'VICTOR MERS' - CC: "
"To: 'VICTOR MERS'; SANDERS; IRENA; AINA NELSON - CC: "
And I would like to get:
"To: JSMITH1#MYCOMPANY.COM - CC: IRENA#ENTERPRISE.COM"
"To: JSMITH1#MYCOMPANY.COM; VMERS#TESTCOMPANY.COM - CC: "
"To: VMERS#TESTCOMPANY.COM; IRENA#ENTERPRISE.COM; A.NELSON#TESTCOMPANY.COM - CC: "
Thanks in advance for any help
SAI

Answer 1

Instead of using To/CC/BCC properties, use the Recipients collection, loop through all recipients, and for each recipient read the Recipient.Name and Recipient.Address properties. To distinguish the recipient types, check the Recipient.Type property (olTo / olCC / olBCC).
Keep in mind that for the EX recipients, you will get an EX type address, not SMTP. In that case you'd need to access Recipient.AddressEntry.Type property, and if it is "EX", use Recipient.AddressEntry.GetExchangeUser().PrimarySmtpAddress property.