Copy email prefix to clipboard?

[TrippyTom]

Hi gang,

My workplace finally switched to Outlook 2010 and I want to copy the email address, but only the part BEFORE the @ sign and nothing else. I was able to do this in Outlook 2003 easily, but 2010 makes it more difficult.

I figured out if I double-click the sender, it takes me to the contact card. Then if I double-click again it takes me to a new message to that sender. I can then double-click again (that's 6 times now) to get just the first part.

Isn't there an easier way?

[skatonni]

' http://www.cpearson.com/excel/Clipboard.aspx
' Reference the Microsoft Forms Object Library.


Public Sub GetSmtpAddressOfCurrentEmail()
' http://www.gregthatcher.com/Scripts/VBA/Outlook/GetSmtpAddress.aspx
Dim currentItem As Object
Dim currentMail As MailItem
Dim smtpAddress As String

Dim posAtFromRight As Long
Dim LeftLen As Long
Dim uSenderName As String

Dim DataObj As New MSForms.DataObject

Set currentItem = Application.ActiveInspector.currentItem

If currentItem.Class = olMail Then
Set currentMail = currentItem

smtpAddress = GetSmtpAddress(currentMail)
'MsgBox "SMTP Address is " & smtpAddress

'Debug.Print "SMTP Address is " & smtpAddress
'Debug.Print "Length of SMTP Address is " & Len(smtpAddress)

posAtFromRight = InStrRev(smtpAddress, "@")
'Debug.Print posAtFromRight

LeftLen = Len(smtpAddress) - (Len(smtpAddress) - (posAtFromRight - 1))

uSenderName = Left(smtpAddress, LeftLen)
'Debug.Print "uSenderName is " & uSenderName

DataObj.SetText uSenderName
DataObj.PutInClipboard

Debug.Print uSenderName & " is now in the clipboard."

Else
MsgBox "Open a mailitem."

End If

End Sub


Public Function GetSmtpAddress(mail As MailItem)
On Error GoTo On_Error

GetSmtpAddress = ""

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