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