I am having trouble detecting an in-firm (EX type) invalid email address of an outlook recipient using the following code:
The invalid email address has a typographical error say, tes#mail.com for test#mail.com.
How do I detect an in-firm recipient having an invalid email address?
Dim Email as Outlook.Mailitem
Dim Recipients As Outlook.Recipients
Set Recipients = Email.Recipients
Recipients.Resolveall
If Not Recipients.ResolveAll Then
For i = Recipients.Count To 1 Step -1
If Not Recipients(i).Resolved Then
MsgBox Recipients(i).Name
End If
Next i
End if
Have you checked the following code:
Public Function ResolveDisplayNameToSMTP(sFromName, OLApp As Object) As String
Dim oRecip As Object 'Outlook.Recipient
Set oRecip = OLApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
oRecipName = oRecip.Name
If oRecip.Resolved And InStr(oRecipName, "#") = 0 Then
ResolveDisplayNameToSMTP = "Valid"
Else
ResolveDisplayNameToSMTP = "Not Valid"
End If
End Function
For more, please see this: VBA CODE to Verify Email Address Found in Outlook Global Address List
Related
I want a warning every time I try to send an email outside my company, where external email addresses are those that don't end in the mycompany.com domain.
This prompts every time I send an email, regardless of the recipient or recipients.
It should only prompt if at least one of the to/cc/bcc recipients has an email address with a different domain.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xMailItem As Outlook.MailItem
Dim xRecipients As Outlook.Recipients
Dim i As Long
Dim xRecipientAddress As String
Dim xPrompt As String
Dim xYesNo As Integer
Dim xPos As Integer
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Set xMailItem = Item
Set xRecipients = xMailItem.Recipients
For i = xRecipients.Count To 1 Step -1
xRecipientAddress = xRecipients.Item(i).Address
xPos = InStrRev(LCase(xRecipientAddress), "#mycompany.com")
If xPos <= 0 Then Exit For
Cancel = False
Next
If InStrRev(LCase(xRecipientAddress), "#mycompany.com") > 0 Then Exit Sub
xPrompt = "Are you sure you want to send this email outside of The Company?"
xYesNo = MsgBox(xPrompt, vbYesNo + vbQuestion, "External Email Warning")
If xYesNo = vbNo Then Cancel = True
End Sub
The Recipient.Address may not return an SMTP email address in case of Exchange accounts. Microsoft Exchange Server can operate with email address types such as Exchange, SMTP, X.400, Microsoft Mail, etc. By default, the Address property of the Recipient class returns just an Exchange type address, for example this one:
/O=ORGANIZATION_NAME /OU=EXCHANGE_GROUP /CN=RECIPIENTS /CN=USER_NAME
To get other address types, we need to find the recipient in the Outlook address book by using the IAddrBook.ResolveName method, then reach the IMailUser interface with the IAddrBook.OpenEntry method and get the PR_EMS_AB_PROXY_ADDRESSES property. Read more about that in the HowTo: Convert Exchange-based email address into SMTP email address article.
Also you may consider using the AddressEntry property of the Recipient class return an object which represents a person, group, or public folder to which the messaging system can deliver messages. You can check out the AddressEntry.AddressEntryUserType property which returns a constant from the OlAddressEntryUserType enumeration representing the user type of the AddressEntry. In case of Exchange entry you need to use the following sequence of property and method calls:
Recipient.AddressEntry.GetExchangeUser().PrimarySmtpAddress
The ExchangeUser.PrimarySmtpAddress property returns a string representing the primary Simple Mail Transfer Protocol (SMTP) address for the ExchangeUser.
I think this logic is easier to follow. I believe InStr is sufficient.
Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xMailItem As MailItem
Dim xRecipients As Recipients
Dim i As Long
Dim xRecipientAddress As String
Dim xPrompt As String
Dim xYesNo As VbMsgBoxResult
Dim xPos As Long
If Item.Class <> olMail Then Exit Sub
Set xMailItem = Item
Set xRecipients = xMailItem.Recipients
For i = xRecipients.count To 1 Step -1
xRecipientAddress = xRecipients.Item(i).Address
Debug.Print xRecipientAddress
' Use text from internal xRecipientAddress
xPos = InStr(LCase(xRecipientAddress), "#mycompany.com")
Debug.Print xPos
If xPos = 0 Then
xPrompt = "Are you sure you want to send this email outside of The Company?"
xYesNo = MsgBox(xPrompt, vbYesNo + vbQuestion, "External Email Warning")
If xYesNo = vbNo Then Cancel = True
Exit For
End If
Next
End Sub
I would like to display a message when sending to an external address. I used various stack overflow questions to create the VBA below. I use Office 365.
I found that a recipient which Outlook has assigned as an Outlook nickname does not resolve with an SMTP address.
Instead, the Recipients.Item(i).Address attribute resolves to something like
/o=NT5/ou=00000000000000000000000000000000/cn=122E0E7203FE4F448EC35B53EE8523A4
from which I am unable to extract the SMTP address. I need to check if this recipient is an external recipient.
I tried using the Recipients.Item(i).Name attribute (which just includes the first part of the address before the #) and attempted to resolve this using Session.CreateRecipient, but this fails. I also tried the same with the Recipients.Item(i).Address attribute.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xMailItem As Outlook.MailItem
Dim xRecipients As Outlook.Recipients
Dim i As Long
Dim xRecipientAddress As String
Dim xExternal As Integer
On Error Resume Next
xExternal = 0
If Item.Class <> olMail Then
Exit Sub
End If
Set xMailItem = Item
Set xRecipients = xMailItem.Recipients
For i = xRecipients.Count To 1 Step -1
xRecipientAddress = xRecipients.Item(i).Address
If Left(xRecipientAddress, 1) <> "/" Then
'external address
If InStrRev(LCase(xRecipientAddress), "#email.domain") = 0 Then
'Any other SMTP Email domain
xExternal = 1
End If
Else
'catch for outlook nickname cache
If Left(xRecipientAddress, 6) = "/o=NT5" Then
'Code to get SMTP address from outlook nickname
End If
End If
Next
Note the #email.domain is updated in my code to our SMTP domain name
The code should assign xExternal = 1 if any external recipients are found in the recipients list. This should include any recipients Outlook has created an Outlook Nickname for and those with just SMTP addresses.
Use:
If Left(xRecipientAddress, 6) = "/o=NT5" Then
Debug.Print xRecipients.Item(i).AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
Also, i don't think /0=NT5 will be consistent, so might want to change that.
I am working on an automation on mails in outlook VBA. I want to use PR_VERB_EXECUTION_TIME property to get the latest status of mail and check whether the mail has already been replied or forwarded and send mail if the mail is unattended. Any help in
Sub Test(Item AS MailItem)
//Item is my incoming mail
Dim Obj As Outlook.MailItem
Dim str As String
Dim propaccessor As Outlook.Propertyaccessor
Set propaccessor = Item.propertyAccessor
str = propaccessor.Getproperty("http://schemas.microsoft.com/mapi/proptag/0x10820040")
'Str value is setting to null due to which error is thrown
'but other properties are working fine
'i want to use this string and compare current time and then reply if it is equal to current time
End Sub
how to use the property is appreciated!.
for that you need to use PropertyAccessor.GetProperty Method
For Each mailItem In mailitems
If mailItem.Class <> olMail Then Exit For
Set propertyAccessor = mailItem.propertyAccessor
LastVerbExecuted = CheckBlankFields("PR_LAST_VERB_EXECUTED", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10810003"))
Select Case LastVerbExecuted
Case Last_Verb_Reply_All, Last_Verb_Reply_Sender, Last_Verb_Reply_Forward
Subject = mailItem.Subject
'This appears to be local time
RecievedTime = mailItem.ReceivedTime
'This appears to be GMT
strRepliedTime = CheckBlankFields("PR_LAST_VERB_EXECUTION_TIME", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10820040"))
OriginalAuthor = mailItem.Sender
'Replier = ...
If strRepliedTime <> "" Then
'Convert string strRepliedTime to time format here...using a custom function
End If
LogData Subject, OriginalAuthor, Replier, RecievedTime, RepliedTime
Case Else
'in case you want to do something here
End Select
Next mailItem
Refer http://www.tek-tips.com/viewthread.cfm?qid=1739523
you can do this way
Const Last_Verb_Reply_All = 103
Const Last_Verb_Reply_Sender = 102
Const Last_Verb_Reply_Forward = 104
For Each mailItem In mailitems
If mailItem.Class <> olMail Then Exit For
Set propertyAccessor = mailItem.propertyAccessor
LastVerbExecuted = CheckBlankFields("PR_LAST_VERB_EXECUTED", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10810003"))
Select Case LastVerbExecuted
Case Last_Verb_Reply_All, Last_Verb_Reply_Sender, Last_Verb_Reply_Forward
'it means email already responded
exit sub
'i dont think there is need to check time
'strRepliedTime = CheckBlankFields("PR_LAST_VERB_EXECUTION_TIME", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10820040"))
Case Else
'in case you want to do something here
End Select
Next mailItem
I want to delete an email from the Sent Items folder after the email is forwarded with a rule.
I tried to use "brettdj" code from another post:Macro to delete an email but it's not working for me at all .
what I'm looking for it's a vba macro that can delete an email when you run the script with the rule.
any idea how I can accomplished that
thanks in advance
You don't have a corresponding entry in your contacts folder (address book). The Add method of the Recipients class accepts the name of the recipient; it can be a string representing the display name, the alias, or the full SMTP e-mail address of the recipient.
Sub forwardEmail(itm As Outlook.MailItem)
Dim oExplorer As Outlook.Explorer
Dim oMail As Outlook.MailItem
Dim oOldMail As Outlook.MailItem
Set oExplorer = Application.ActiveExplorer
If oExplorer.Selection.Item(1).Class = olMail Then
Set oOldMail = oExplorer.Selection.Item(1)
Set oMail = oOldMail.Forward
oMail.Recipients.Add "test#gmail.com"
oMail.Recipients.Item(1).Resolve
If oMail.Recipients.Item(1).Resolved Then
'delete forwarded email from sent items
oMail.DeleteAfterSubmit = True
oMail.Send
'delete original email from inbox
'oOldMail.Delete
Else
MsgBox "Could not resolve " & oMail.Recipients.Item(1).Name
End If
Else
MsgBox "Not a mail item"
End If
End Sub
Goal: Silently (no dialog box) delete one or more email addresses from recipient collection on ItemSend.
Seems I need to remove recipients by name or index. How do I obtain the index of the email or match it to an SMTP address.
I found some code at the bottom of this message that obtains the SMTP address, but can't find code that I need to start with which is to simply remove a recipient. Then looping it all and matching to an SMTP address seems daunting.
What I'd like to happen
Sub DoNotEmailTheseAddresses()
Dim Msg As Outlook.MailItem
Set Msg = Outlook.CreateItem(olMailItem)
With Msg
run through IndexNumber to find recipients in To:, CC:, and BCC: collection
If RecipientIndexNumber.SMTPaddress = "somebody#adomain.com"
RecipientIndexNumber.SMTPaddress.Remove
If RecipientIndexNumber.SMTPaddress = "somebodyELSEtoo#adomain.com"
RecipientIndexNumber.SMTPaddress.Remove
End With
End Sub
....and off goes the email with somebody#adomain.com and somebodyELSEtoo#adomain.com handily removed.
Getting the corresponding SMTP address code is on MSDN site. http://msdn.microsoft.com/en-us/library/office/ff866259(v=office.15).aspx
Sub GetSMTPAddressForRecipients(mail As Outlook.MailItem)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = mail.Recipients
For Each recip In recips
Set pa = recip.PropertyAccessor
Debug.Print recip.name & " SMTP=" _
& pa.GetProperty(PR_SMTP_ADDRESS)
Next
End Sub
you are not that far away....
For each mail-address you want to remove, you have to go through all recipients and check if they have this mail-address. If yes, remove them. therefor I have put this into a separate function, which you can call for each mail-address you want to remove.
Public Sub newItem_Open(Cancel As Boolean)
Call removerecipi(newItem, "somebody#adomain.com")
End Sub
Function removerecipi(mailitem As Outlook.mailitem, rec_mail As String)
Dim i As Long
restart:
For i = 1 To mailitem.Recipients.Count
If i > mailitem.Recipients.Count Then GoTo restart
If mailitem.Recipients(i).SmtpAddress = rec_mail Then mailitem.Recipients.Remove i
Next i
End Function
why is the restart necessary: after removing one recipient, the mailItem.Recipients.Count needs to be reset. There are also other Solutions, however this one works fine.