S
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
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