Outlook VBA Script that gets SMTP Address of the Currently Selected Email

' Outlook VBA Script that gets SMTP Address of the Currently Selected Email
' This script can convert an Exchange address into an SMTP address
' Use Tools->Macro->Security to allow Macros to run, then restart Outlook
' Run Outlook, Press Alt+F11 to open VBA
' Programming by Greg Thatcher, http://www.GregThatcher.com
Option Explicit

Public Sub GetSmtpAddressOfCurrentEmail()
    Dim Session As Outlook.NameSpace
    Dim currentExplorer As Explorer
    Dim Selection As Selection
    Dim currentItem As Object
    Dim currentMail As MailItem
    Dim smtpAddress As String
    Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection
    'for all items do...
    For Each currentItem In Selection
        If currentItem.Class = olMail Then
            Set currentMail = currentItem
            smtpAddress = GetSmtpAddress(currentMail)
            MsgBox "SMTP Address is " & smtpAddress
        End If
End Sub
Public Function GetSmtpAddress(mail As MailItem)
    On Error GoTo On_Error
    GetSmtpAddress = ""
    Dim Report As String
    Dim Session As Outlook.NameSpace
    Set Session = Application.Session
    If mail.SenderEmailType <> "EX" Then
        GetSmtpAddress = mail.SenderEmailAddress
        Dim senderEntryID As String
        Dim sender As AddressEntry
        PR_SENT_REPRESENTING_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x00410102"
        senderEntryID = mail.PropertyAccessor.BinaryToString( _
            mail.PropertyAccessor.GetProperty( _
        Set sender = Session.GetAddressEntryFromID(senderEntryID)
        If sender Is Nothing Then
            Exit Function
        End If
        If sender.AddressEntryUserType = olExchangeUserAddressEntry Or _
            sender.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
            Dim exchangeUser As exchangeUser
            Set exchangeUser = sender.GetExchangeUser()
            If exchangeUser Is Nothing Then
                Exit Function
            End If
            GetSmtpAddress = exchangeUser.PrimarySmtpAddress
            Exit Function
            Dim PR_SMTP_ADDRESS
            PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
            GetSmtpAddress = sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
        End If
    End If
        Exit Function
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting
End Function

Problems, Comments, Suggestions? Click here to contact Greg Thatcher

Please read my Disclaimer

Copyright (c) 2013 Thatcher Development Software, LLC. All rights reserved. No claim to original U.S. Gov't works.