14

I have been using VBA to some degree, using this code:

Sub ExtractEmail()
Dim OlApp As Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")
' Setup Namespace
Set NS = ThisOutlookSession.Session
' Display select folder dialog
Set Folder = NS.PickFolder
' Create Text File
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\mydocuments\emailss.txt", True)
' loop to read email address from mail items.
For Each Mailobject In Folder.Items
   Email = Mailobject.To
   a.WriteLine (Email)
Next
Set OlApp = Nothing
Set Mailobject = Nothing
a.Close
End Sub

However this gives output as the names of the email addresses and not the actual email address with the "something@this.domain".

Is there an attributte of the mailobject that will allow the email addresses and not the names to be written from the 'To' Textbox.

Thanks

Martijn Pieters
  • 1,048,767
  • 296
  • 4,058
  • 3,343
tread
  • 10,133
  • 17
  • 95
  • 170

5 Answers5

21

Check out the Recipients collection object for your mail item, which should allow you to get the address: http://msdn.microsoft.com/en-us/library/office/ff868695.aspx

Update 8/10/2017

Looking back on this answer, I realized I did a bad thing by only linking somewhere and not providing a bit more info.

Here's a code snippet from that MSDN link above, showing how the Recipients object can be used to get an email address (snippet is in VBA):

Sub GetSMTPAddressForRecipients(mail As Outlook.MailItem) 
    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 = mail.Recipients 
    For Each recip In recips 
        Set pa = recip.PropertyAccessor 
        Debug.Print recip.name &; " SMTP=" _ 
           &; pa.GetProperty(PR_SMTP_ADDRESS) 
    Next 
End Sub
Jake Bathman
  • 1,268
  • 3
  • 18
  • 25
5

It looks like, for email addresses outside of your organization, the SMTP address is hidden in emailObject.Recipients(i).Address, though it doesn't seem to allow you to distinguish To/CC/BCC.

The Microsoft code was giving me an error, and some investigating reveals that the schema page is no longer available. I wanted a semicolon-delaminated list of email addresses that were either in my Exchange organization or outside of it. Combining it with another S/O answer to convert inner-company email display names to SMTP names, this does the trick. 

Function getRecepientEmailAddress(eml As Variant)
    Set out = CreateObject("System.Collections.Arraylist") ' a JavaScript-y array

    For Each emlAddr In eml.Recipients
        If Left(emlAddr.Address, 1) = "/" Then
            ' it's an Exchange email address... resolve it to an SMTP email address
            out.Add ResolveDisplayNameToSMTP(emlAddr)
        Else
            out.Add emlAddr.Address
        End If
    Next
    getRecepientEmailAddres = Join(out.ToArray(), ";")
End Function

If the email is inside your organization, you need to convert it to an SMTP email address. I found this function from another StackOverflow answer helpful: 

Function ResolveDisplayNameToSMTP(sFromName) As String
    ' takes a Display Name (i.e. "James Smith") and turns it into an email address (james.smith@myco.com)
    ' necessary because the Outlook address is a long, convoluted string when the email is going to someone in the organization. 
    ' source:  https://stackoverflow.com/questions/31161726/creating-a-check-names-button-in-excel

    Dim OLApp As Object 'Outlook.Application
    Dim oRecip As Object 'Outlook.Recipient
    Dim oEU As Object 'Outlook.ExchangeUser
    Dim oEDL As Object 'Outlook.ExchangeDistributionList

    Set OLApp = CreateObject("Outlook.Application")
    Set oRecip = OLApp.Session.CreateRecipient(sFromName)
    oRecip.Resolve
    If oRecip.Resolved Then
        Select Case oRecip.AddressEntry.AddressEntryUserType
            Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
                Set oEU = oRecip.AddressEntry.GetExchangeUser
                If Not (oEU Is Nothing) Then
                    ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
                End If
            Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
                    ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
        End Select
    End If
End Function
Steven
  • 181
  • 2
  • 2
4

The answers above did not work for me. I think they only work when the recipient is in the address book. The following code is also to able to lookup email addresses from outside the organisation. Additionally it makes a distinction between to/cc/bcc

    Dim olRecipient As Outlook.Recipient
    Dim strToEmails, strCcEmails, strBCcEmails As String

    For Each olRecipient In item.Recipients
           
        Dim mail As String
        If olRecipient.AddressEntry Is Nothing Then
            mail = olRecipient.Address
        ElseIf olRecipient.AddressEntry.GetExchangeUser Is Nothing Then
            mail = olRecipient.Address
        Else
            mail = olRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
        End If
        
        Debug.Print "resolved", olRecipient.Name, mail
        
        If olRecipient.Type = Outlook.OlMailRecipientType.olTo Then
            strToEmails = strToEmails + mail & ";"
        ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olCC Then
            strCcEmails = strCcEmails + mail & ";"
        ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olBCC Then
            strBCcEmails = strBCcEmails + mail & ";"
        End If
        
    Next
    Debug.Print strToEmails
    Debug.Print strCcEmails
    Debug.Print strBCcEmails
andreasDL
  • 41
  • 1
3

Another code alternative (based initially on the answer by @andreasDL) which should be able to be used...

Pass in a MailItem to the EmailAddressInfo function to get an array of the Sender, To and CC fields from the message

Private Const olOriginator As Long = 0, olTo As Long = 1, olCC As Long = 2, olBCC As Long = 3
'BCC addresses are not included within received messages

Function PrintEmailAddresses(olItem As MailItem)
    If olItem.Class <> olMail Then Exit Function
    
    Dim Arr As Variant: Arr = EmailAddressInfo(olItem)
    Debug.Print "Sender: " & Arr(olOriginator)
    Debug.Print "To Address: " & Arr(olTo)
    Debug.Print "CC Address: " & Arr(olCC)
End Function

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
            
    With olItem
        Select Case UCase(.SenderEmailType)
            Case "SMTP": Originator = .SenderEmailAddress
            Case Else
                Set olEU = .Sender.GetExchangeUser
                If Not olEU Is Nothing Then Originator = olEU.PrimarySmtpAddress
        End Select
    End With
    
    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(Originator, ToAddress, CCAddress)
ExitFunction:
End Function
Tragamor
  • 3,594
  • 3
  • 15
  • 32
  • This is great!!! I don't know why you didn't include BCC Case, hope you don't mind I added it. – FreeSoftwareServers Aug 25 '21 at 00:20
  • BCC is blind. the addresses aren't saved so no point in adding it as a case. I did originally have it in, but took it out when I realised it added no value. – Tragamor Aug 25 '21 at 00:40
  • As this is a `function` its uses are unknown and limitless. While we may not be using the BCC function, I can see for example, it is still in my `Sent` e-mail folder email itmes, so if I ever needed to do something with those e-mails, I would have the BCC option. I see 0 benefit to removing it from the function. If you don't want to add it back, I will write up my own answer. @Tragamor – FreeSoftwareServers Sep 09 '21 at 15:34
0

This is what worked for me with Outlook 2019. Use your internal domain name(s). Might need some tweaking yet - not heavily tested. Place code in the ThisOutlookSession module. (Updated to handle Exchange distribution lists 7/31/20.)

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xMailItem As Outlook.MailItem
Dim xRecipients As Outlook.Recipients
Dim OutRec As Outlook.Recipient
Dim OutTI As Outlook.TaskItem
Dim i As Long
Dim j As Long
Dim xOKCancel As Integer
Dim sMsg As String
Dim oMembers As AddressEntries
Dim oMember As AddressEntry
Dim sDomains As String
Dim sTemp As String

On Error Resume Next
If Item.Class <> olMail Then GoTo ExitCode
sDomains = "@test1.com @test2.com"
Set xMailItem = Item
Set xRecipients = xMailItem.Recipients

'Loop through email recipients to get email addresses
For i = xRecipients.Count To 1 Step -1
    'If we have a text address entry in the email
    If InStr(xRecipients.Item(i).AddressEntry, "@") > 0 Then
        sTemp = xRecipients.Item(i).AddressEntry
        If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "@"), 254))) <= 0 Then
            sMsg = sMsg & sTemp & vbCrLf
        End If
    Else
        Select Case xRecipients.Item(i).AddressEntry.DisplayType
            Case Is = olDistList
                Set oMembers = xRecipients.Item(i).AddressEntry.Members
                For j = oMembers.Count To 1 Step -1
                    Set oMember = oMembers.Item(j)
                    sTemp = oMember.GetExchangeUser.PrimarySmtpAddress
                    If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "@"), 254))) <= 0 Then
                        sMsg = sMsg & sTemp & vbCrLf
                    End If
                    Set oMember = Nothing
                Next j
                Set oMembers = Nothing
            Case Is = olUser
                Set OutTI = Application.CreateItem(3)
                OutTI.Assign
                Set OutRec = OutTI.Recipients.Add(xRecipients.Item(i).AddressEntry)
                OutRec.Resolve
                If OutRec.Resolved Then
                    sTemp = OutRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                    If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "@"), 254))) <= 0 Then
                         sMsg = sMsg & sTemp & vbCrLf
                    End If
                End If
                Set OutTI = Nothing
                Set OutRec = Nothing
            Case Else
                MsgBox "Unaccomodated AddressEntry.DisplayType."
                GoTo ExitCode
        End Select
    End If
Next i

'Display user message
If Len(sMsg) > 0 Then
    sMsg = "This email is addressed to the following external Recipients:" & vbCrLf & vbCrLf & sMsg
    xOKCancel = MsgBox(sMsg, vbOKCancel + vbQuestion, "Warning")
    If xOKCancel = vbCancel Then Cancel = True
End If

End Sub
phillfri
  • 71
  • 1
  • 3