All Email Addresses in "TO" Section VBA

Question

I am trying to get all the email addresses in "TO" section of received mails. This code is giving a link ( like below) for each mail. I am not sure how to fetch the email address and NOT A LINK OR THE DISPLAY NAME FOR THE EMAIL.

Any help is highly appreciated !

It's giving a link like below instead of Email address in "TO" -

"/o=ExchangeLabs/ou=Exchange Administrative Group (FYDIBOHF23SPDLT)/cn=Recipients/cn=636da3beeae34f2493a3ee2c93d44007-LC",

where LC is the display name of the account mail is received from.

Sub openLeaseInbox()
    Dim oOutlook As Outlook.Application
    Dim oFolder As Outlook.Folder
    Dim oMailBox As String
    Dim oFldr As String
    Dim XDate As Date
    Dim i As Integer
    Dim olMail As Outlook.MailItem
    Dim olrecips As Outlook.Recipients
    Dim olrecip As Outlook.Recipient
    Dim LR As Integer
    Range("L2").Value = "3/20/2022"
    XDate = Format(ThisWorkbook.Sheets("Email Download").Range("L2").Value, "mm/dd/yyyy")
    Set oOutlook = CreateObject("Outlook.Application")
    Set oNS = oOutlook.GetNamespace("MAPI")
    oMailBox = "Lease QC"oFldr = "Inbox"
    Set oFolder = oNS.Folders(oMailBox).Folders(oFldr)
    If (oOutlook.ActiveExplorer Is Nothing) Then
        oFolder.Display
        Else
        Set oOutlook.ActiveExplorer = oFolder
    End If
    i = 1
    For Each olMail In oFolder.Items.Restrict("[ReceivedTime] < '" & XDate & "' ")
        Set olrecips = olMail.Recipients
        Range("A1").Offset(i, 0).Value = olMail.Subject
        Range("B1").Offset(i, 0).Value = olMail.ReceivedTime
        For Each olrecip In olrecips
             Range("C1").Offset(i, 0).Value = olrecip.Address   ' Seems there is a problem here'
        Next
             Range("D1").Offset(i, 0).Value = olMail.body
    i = i + 1
    Next olMail
End Sub

Please see here: https://stackoverflow.com/a/66484483/3688861 — Tragamor, Apr 05 '22 at 16:57
I am sorry but I am not that proficient at VBA, and not able to incorporate the suggested solution to my existing code, Can you suggest a simpler solution or let me know how to incorporate the suggested solution to my existing code — Ren_07, Apr 05 '22 at 17:23

score 0 · Answer 1 · answered Apr 07 '22 at 03:12

I Solved it using a function. Below is the full working code for any future reference. Thanks for help !!

Sub openLeaseInbox()

Dim oOutlook As Outlook.Application
Dim oFolder As Outlook.Folder
Dim oMailBox As String
Dim oFldr As String
Dim XDate As Date
Dim i As Integer
Dim olMail As Outlook.MailItem
Dim olrecips As Outlook.Recipients
Dim olrecip As Outlook.Recipient
Dim LR As Integer

Range("L2").Value = "4/3/2022"
XDate = Format(ThisWorkbook.Sheets("Total Data").Range("L2").Value, "mm/dd/yyyy")

Set oOutlook = CreateObject("Outlook.Application")
Set oNS = oOutlook.GetNamespace("MAPI")
oMailBox = "Lease QC"
oFldr = "Inbox"
Set oFolder = oNS.Folders(oMailBox).Folders(oFldr)

    If (oOutlook.ActiveExplorer Is Nothing) Then
        oFolder.Display
        Else
        Set oOutlook.ActiveExplorer = oFolder
    End If

i = 1

For Each olMail In oFolder.Items.Restrict("[ReceivedTime] > '" & XDate & "' ")
        Dim ToAddress As String
        Set olrecips = olMail.Recipients
        Range("A1").Offset(i, 0).Value = olMail.Subject
        Range("B1").Offset(i, 0).Value = olMail.ReceivedTime
        Range("C1").Offset(i, 0).Value = EmailAddressInfo(olMail)
        Range("D1").Offset(i, 0).Value = olMail.body
        i = i + 1
    
Next olMail

End Sub

Private Function EmailAddressInfo(olItem As MailItem) As Variant
    If olItem.Class <> olMail Then Exit Function
    
On Error GoTo ExitFunction
    
    Dim olRecipient As Outlook.Recipient
    Dim olEU As Outlook.ExchangeUser
    Dim olEDL As Outlook.ExchangeDistributionList
    Dim ToAddress, CCAddress, Originator, email As String
                
    For Each olRecipient In olItem.Recipients
       With olRecipient
            Select Case .AddressEntry.AddressEntryUserType
                Case olSmtpAddressEntry 'OlAddressEntryUserType.
                    email = .Address
                Case olExchangeDistributionListAddressEntry, olOutlookDistributionListAddressEntry
                    Set olEDL = .AddressEntry.GetExchangeDistributionList
                    email = IIf(Not olEDL Is Nothing, olEDL.PrimarySmtpAddress, "")
                Case Else
                    Set olEU = .AddressEntry.GetExchangeUser
                    email = IIf(Not olEU Is Nothing, olEU.PrimarySmtpAddress, "")
            End Select
            If email <> "" Then
                Select Case .Type
                    Case olTo: ToAddress = ToAddress & email & ";"
                    Case olCC: CCAddress = CCAddress & email & ";"
                End Select
            End If
        End With
    Next
    EmailAddressInfo = Array(ToAddress, CCAddress)
ExitFunction:
End Function

All Email Addresses in "TO" Section VBA

1 Answers1