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
    Next
    
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
    Else
        Dim senderEntryID As String
        Dim sender As AddressEntry
        Dim PR_SENT_REPRESENTING_ENTRYID As String
        
        PR_SENT_REPRESENTING_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x00410102"
        
        senderEntryID = mail.PropertyAccessor.BinaryToString( _
            mail.PropertyAccessor.GetProperty( _
                PR_SENT_REPRESENTING_ENTRYID))
        
        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
        Else
            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
    
    
Exiting:
        Exit Function
On_Error:
    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.