How to get recipient email address from Excel?

Question

I'm trying to get the .To email address from my sent box using Excel-VBA. However, To only returns the name not the email address. After some search found that the recipient should be what I'm looking for. Tried by following the msdn guide, but the code does not seem to work.

Sub test()

Dim objoutlook As Object 
Dim objNamespace As Object 
Dim olFolder As Object
Dim OutlookMail As outlook.MailItem

Set objoutlook = CreateObject("Outlook.Application") 
Set objNamespace = objoutlook.GetNamespace("MAPI") 
Set olFolder = objNamespace.GetDefaultFolder(olFolderSentMail) 
Set OutlookMail = objoutlook.CreateItem(olMailItem)

    Dim recips As outlook.Recipients
    Dim recip As outlook.Recipient
    Dim pa As outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set recips = OutlookMail.Recipients
    For Each recip In recips    'Something is wrong here
        Set pa = recip.PropertyAccessor
        Debug.Print recip.Name & " SMTP=" & pa.GetProperty(PR_SMTP_ADDRESS)
    Next


Set olFolder = Nothing 
Set objNamespace = Nothing 
Set objoutlook = Nothing

End Sub

I'm not really familiar with VBA, please guide along.

Answer 1

this is my way of getting Recipient email Address. I hope it would help you.

Sub CopyCurrentContact()

   Dim objRcp As Outlook.Recipient
   Dim objRcpS As Outlook.Recipients
   Dim rcpStr As String
   Set outLookObj = CreateObject("Outlook.Application")
   Set InspectorObj = outLookObj.ActiveInspector
   Set ItemObj = InspectorObj.CurrentItem



  Set objRcpS = ItemObj.Recipients

  For Each objRcp In objRcpS

    rcpStr = objRcp.Address & "; " & rcpStr

    Debug.Print rcpStr
  Next objRcp





End Sub

Answer 2

You can try this:

Private Sub GetRecipientSMTP(objAllRecip As Outlook.Recipients)

    Dim objRecip As Outlook.Recipient
    Dim objExUser As Outlook.ExchangeUser
    Dim objExDisUser As Outlook.ExchangeDistributionList

    For Each objRecip In objAllRecip
        Select Case objRecip.AddressEntry.AddressEntryUserType
        Case 0, 10
            Set objExUser = objRecip.AddressEntry.GetExchangeUser
            If Not objExUser Is Nothing Then _
            Debug.Print objExUser.PrimarySmtpAddress '/* or copy somewhere */

        Case 1
            Set objExDisUser = objRecip.AddressEntry.GetExchangeDistributionList
            If Not objExDisUser Is Nothing Then _
            Debug.Print objExDisUser.PrimarySmtpAddress '/* or copy somewhere */
        Case Else
        '/* Do nothing, recipient not recognized */
        End Select
    Next

End Sub

You can run it in your sub like below using recips from your code (or see sample usage).

GetRecipientSMTP recips

Basically, this will check on the each Recipient on Recipients you supplied.
Then will check if it is an ExchangeUser type or ExchangeDistributionList before returning the PrimartSMTPAddress. HTH.

Sample Usage:

Sub marine()

    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim olFolder As Outlook.Folder
    Dim olMail As Outlook.MailItem
    Dim i As Integer

    Set olApp = GetObject(, "Outlook.Application") '/* assuming OL is running */
    Set olNs = olApp.GetNamespace("MAPI")
    Set olFolder = olNs.GetDefaultFolder(olFolderInbox)

    With olFolder
        For i = .Items.Count To 1 Step -1
            If TypeOf .Items(i) Is MailItem Then
                Set olMail = .Items(i)
                GetRecipientSMTP olMail.Recipients
            End If
            Exit For '/* I just want to process the first mail */
        Next
    End With

End Sub

_{Note: I used early binding and set reference to Outlook Object Library.}

Answer 3

Quick Example

Option Explicit
Public Sub Example()
    Dim OUTLOOK_APP As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim SENT_FLDR As MAPIFolder
    Dim Items As Outlook.Items
    Dim olRecip As Outlook.Recipient
    Dim olRecipAddress As String
    Dim i As Long

    Set OUTLOOK_APP = New Outlook.Application
    Set olNs = OUTLOOK_APP.GetNamespace("MAPI")

    Set SENT_FLDR = olNs.GetDefaultFolder(olFolderSentMail)
    Set Items = SENT_FLDR.Items

    For i = Items.Count To 1 Step -1
        DoEvents
        If Items(i).Class = olMail Then

            For Each olRecip In Items(i).Recipients
                olRecipAddress = olRecip.Address
                Debug.Print olRecipAddress
            Next

        End If
    Next
End Sub