List of recipients (To and CC) from outlook 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: [email protected]";"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: [email protected]";"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: [email protected] - CC: [email protected]"

"To: [email protected]; [email protected] - CC: "

"To: [email protected]; [email protected]; [email protected] - CC: "

Thanks in advance for any help SAI

Dmitry Streblechenko Dmitry Streblechenko · Accepted Answer · 2020-09-20T18:53:48

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.

List of recipients (To and CC) from outlook email

1 Answers