GURUS HELP! Sender Address Problem

[Sanjay Singh]

I have written some code using info found online and in books to get the
e-mail address of an E-mails Sender. Code is copied at the end of the
message

Code seems to work most of the time but fails for some Exchange addresses.
An example of an address copied from an e-mail that the code failed on is
below.

IMCEAEX-_O=KMZ_OU=FIRST+20ADMINISTRATIVE+20GROUP_CN=RECIPIENTS_CN=SSINGH3393
(e-mail address removed)

I am not familar enough with Exchange to know what is wrong. Any help will
be greatly appreciated.

Thank you.
Sanjay


Public Function SenderEmail(objMsg As MailItem) As String
Dim sItem, PrSenderEmail

Dim strType As String
Dim objSenderAE 'As Redemption.AddressEntry
Dim objSMail 'As Redemption.SafeMailItem

Const PR_SENDER_ADDRTYPE = &HC1E001E
Const PR_EMAIL = &H39FE001E

Dim Addresses
Dim i

On Error GoTo HandleErr
RedemptionCleanup

Set objSMail = CreateObject("qfRedemption.qfSafeMailItem")
objSMail.Item = objMsg
strType = objSMail.Fields(PR_SENDER_ADDRTYPE)

Set objSenderAE = objSMail.Sender
If Not objSenderAE Is Nothing Then
If strType = "SMTP" Then
SenderEmail = objSenderAE.Address
ElseIf strType = "EX" Then
'SenderEmail = objSenderAE.Fields(PR_EMAIL)
Addresses = objSenderAE.Fields(&H800F101E)
For i = LBound(Addresses) To UBound(Addresses)
If Left(Addresses(i), 5) = "SMTP:" Then
SenderEmail = Right(Addresses(i), Len(Addresses(i)) - 5)
End If
Next
End If
End If

ExitHere:
Set objSenderAE = Nothing
Set objSMail = Nothing
RedemptionCleanup
Exit Function

' Error handling block added by Error Handler Add-In. DO NOT EDIT this block
of code.
' Automatic error handler last updated at 10-17-2002 11:16:04
'ErrorHandler:$$D=10-17-2002 'ErrorHandler:$$T=11:16:04
HandleErr:
Select Case Err.Number
Case Else
'MsgBox "Error " & Err.Number & ": " & Err.Description,
vbCritical, "basGlobals.SenderEmail"
'ErrorHandler:$$N=basGlobals.SenderEmail
MsgBox "E-mail address cannot be resolved. Please check e-mail
address.", vbExclamation, "SenderEmail: Invalid E-mail Address"
End Select
GoTo ExitHere
' End Error handling block.
End Function

Sub RedemptionCleanup()
Dim redMAPI 'As Redemption.MAPIUtils
Set redMAPI = CreateObject("qfRedemption.qfMAPIUtils")
redMAPI.Cleanup
Set redMAPI = Nothing
End Sub

 

[Eric Legault [Outlook MVP]]

You need to use CDO to get the SMTP address from an Exchange address:

http://www.cdolive.com/cdo5.htm#EMailAddressOfSender

 

[Sanjay Singh]

The Redemption code works for most Exchange addresses. Only very few such as
the one I had written give a problem.

I am not sure what is wrong with the address but I was hoping someone more
familar with Exchange would be able to spot.

Sanjay