Accessing SMTP Email addresses with VBA Code

[lonesoac0]

Hello all,

I have this code that allows me to select a message and place the Subject, To, CC, and DateTime recieved in the clipboard. The only real issue that i have with this code, is that I am getting the Display Name values instead of the email addresses of the senders. Anyone know what I am missing?

Option Explicit

Sub CopyEmailDetailsToClipboard()
    Dim objItem As Object
    Dim email As MailItem
    Dim clipboard As Object
    Dim emailDetails As String
    Dim emailDate As String
    Dim recipient As Recipient
    Dim toAddresses As String
    Dim ccAddresses As String
    Dim smtpAddress As String
    Dim propertyAccessor As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = "htt~p:/~/schemas.~microsoft.~com/mapi/~proptag/~0x39FE001E"
    
    ' Check if a mail item is selected
    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "Please select an email.", vbExclamation
        Exit Sub
    End If
    
    ' Get the selected item
    Set objItem = Application.ActiveExplorer.Selection.Item(1)
    
    ' Check if the selected item is a mail item
    If TypeOf objItem Is MailItem Then
        Set email = objItem
    Else
        MsgBox "The selected item is not an email.", vbExclamation
        Exit Sub
    End If
    
    ' Choose to use Date Received or Date Sent
    If email.ReceivedTime > 0 Then
        emailDate = "Date Received: " & Format(email.ReceivedTime, "mm/dd/yyyy hh:mm AMPM")
    ElseIf email.SentOn > 0 Then
        emailDate = "Date Sent: " & Format(email.SentOn, "mm/dd/yyyy hh:mm AMPM")
    Else
        emailDate = "No date available."
    End If
    
    ' Collect SMTP email addresses from the "To" field
    For Each recipient In email.Recipients
        If recipient.Type = olTo Then
            Set propertyAccessor = recipient.PropertyAccessor
            smtpAddress = propertyAccessor.GetProperty(PR_SMTP_ADDRESS)
            toAddresses = toAddresses & smtpAddress & "; "
        End If
    Next recipient
    If Len(toAddresses) > 0 Then
        toAddresses = Left(toAddresses, Len(toAddresses) - 2) ' Remove last "; "
    End If
    
    ' Collect SMTP email addresses from the "CC" field, if any
    For Each recipient In email.Recipients
        If recipient.Type = olCC Then
            Set propertyAccessor = recipient.PropertyAccessor
            smtpAddress = propertyAccessor.GetProperty(PR_SMTP_ADDRESS)
            ccAddresses = ccAddresses & smtpAddress & "; "
        End If
    Next recipient
    If Len(ccAddresses) > 0 Then
        ccAddresses = Left(ccAddresses, Len(ccAddresses) - 2) ' Remove last "; "
    End If
    
    ' Build the email details string
    emailDetails = "Subject: " & email.Subject & vbCrLf & _
                   "To: " & toAddresses & vbCrLf
    
    ' Add CC field only if there are addresses in the CC
    If Len(ccAddresses) > 0 Then
        emailDetails = emailDetails & "CC: " & ccAddresses & vbCrLf
    End If
    
    emailDetails = emailDetails & emailDate
    
    ' Create a DataObject to access the clipboard
    On Error Resume Next
    Set clipboard = CreateObject("MSForms.DataObject")
    On Error GoTo 0
    
    ' Check if clipboard object is available
    If clipboard Is Nothing Then
        MsgBox "Unable to access clipboard. Please ensure that the 'Microsoft Forms 2.0 Object Library' is enabled.", vbCritical
        Exit Sub
    End If
    
    ' Copy email details to clipboard
    clipboard.SetText emailDetails
    clipboard.PutInClipboard
    
    ' Notify the user
    MsgBox "Email details copied to clipboard!", vbInformation


End Sub

[ErikEHaml]

Accessing SMTP email addresses using VBA code provides valuable insights into how to handle email details in Outlook rather than marketing, ensuring accurate data management for users.

[Aussiebear]

Maybe this might be worth a look

Option ExplicitSub CopyEmailDetailsToClipboard()
    Dim objItem As Object
    Dim email As MailItem
    Dim clipboard As Object
    Dim emailDetails As String
    Dim emailDate As String
    Dim recipient As Recipient
    Dim toAddresses As String
    Dim ccAddresses As String
    Dim senderAddress As String
    Dim propertyAccessor As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = "htt~p:/~/schemas.~microsoft.~com/mapi/~proptag/~0x39FE001E"
    ' Check if a mail item is selected
    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "Please select an email.", vbExclamation
        Exit Sub
    End If
    ' Get the selected item
    Set objItem = Application.ActiveExplorer.Selection.Item(1)
    ' Check if the selected item is a mail item
    If TypeOf objItem Is MailItem Then
        Set email = objItem
    Else
        MsgBox "The selected item is not an email.", vbExclamation
        Exit Sub
    End If
    ' Choose to use Date Received or Date Sent
    If email.ReceivedTime > 0 Then
        emailDate = "Date Received: " & Format(email.ReceivedTime, "mm/dd/yyyy hh:mm AMPM")
    ElseIf 
        email.SentOn > 0 Then
        emailDate = "Date Sent: " & Format(email.SentOn, "mm/dd/yyyy hh:mm AMPM")
    Else
        emailDate = "No date available."
    End If
    ' Get the SMTP email address of the sender
    Set propertyAccessor = email.Sender.PropertyAccessor
    senderAddress = propertyAccessor.GetProperty(PR_SMTP_ADDRESS)
    ' Collect SMTP email addresses from the "To" field
    For Each recipient In email.Recipients
        If recipient.Type = olTo Then
            Set propertyAccessor = recipient.PropertyAccessor _            
            smtpAddress = propertyAccessor.GetProperty(PR_SMTP_ADDRESS)  _           
            toAddresses = toAddresses & smtpAddress & "; "
        End If
    Next recipient
    If Len(toAddresses) > 0 Then
        toAddresses = Left(toAddresses, Len(toAddresses) - 2) 
        ' Remove last "; "
    End If
    ' Collect SMTP email addresses from the "CC" field, if any
    For Each recipient In email.Recipients
        If recipient.Type = olCC Then
            Set propertyAccessor = recipient.PropertyAccessor _           
            smtpAddress = propertyAccessor.GetProperty(PR_SMTP_ADDRESS) _
            ccAddresses = ccAddresses & smtpAddress & "; "
        End If
    Next recipient
    If Len(ccAddresses) > 0 Then
        ccAddresses = Left(ccAddresses, Len(ccAddresses) - 2) 
        ' Remove last "; "
    End If
    ' Build the email details string
    emailDetails = "Subject: " & email.Subject & vbCrLf &  _
    "From: " & senderAddress & vbCrLf &  _
    "To: " & toAddresses & vbCrLf
    ' Add CC field only if there are addresses in the CC
    If Len(ccAddresses) > 0 Then
        emailDetails = emailDetails & "CC: " & ccAddresses & vbCrLf
    End If
    emailDetails = emailDetails & emailDate
    ' Create a DataObject to access the clipboard
    On Error Resume Next
    Set clipboard = CreateObject("MSForms.DataObject")
    On Error GoTo 0
    ' Check if clipboard object is available
    If clipboard Is Nothing Then
        MsgBox "Unable to access clipboard. Please ensure that the 'Microsoft Forms 2.0 Object Library' is enabled.", vbCritical
        Exit Sub
    End If
    ' Copy email details to clipboard
    clipboard.SetText emailDetails    clipboard.PutInClipboard
    ' Notify the user
    MsgBox "Email details copied to clipboard!", vbInformation
End Sub