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
Related
When sending an email, I want to search the recipients of the email as well as the email body for certain key works, and if found, pop up a message to confirm sending.
I am able to get a pop up when the user hits the send key. I'm unable to access the recipient or message objects to search them.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xPrompt As String
Dim xOkOrCancel As Integer
On Error Resume Next
xPrompt = "Do you want to continue sending the email?"
xOkOrCancel = MsgBox(xPrompt, vbOKCancel)
If xOkOrCancel <> vbOK Then
Cancel = True
End If
End Sub
I added the following code to try to see the recipient, but it is not returning anything.
Set myAddressEntry = myRecipient.AddressEntry
xPrompt = Trim(myAddressEntry)
xOkOrCancel = MsgBox(xPrompt, vbOKCancel)
You are passing a COM object to a function that expects a string. More than that, you don't need the Recipient.AddressEntry property, just work with the Recipient object since it is resolved.
xPrompt = Trim(myRecipient.Name)
I assume you correctly initialize the myRecipient object from the Item.Recipients collection.
I have code that runs when I send an email. It looks at the recipient address and the subject to see if it contains certain words and then pops up a message box to remind us to update our drawing revision control.
It works for internal email addresses and seems to work on some external email addresses. It doesn't like the email address I need to look for.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim hismail As String
Dim strSubject As String
strSubject = Item.Subject
Dim olObj As MailItem
Set olObj = Application.ActiveInspector.CurrentItem
hismail = olObj.Recipients.Item(1).AddressEntry.GetExchangeUser.PrimarySmtpAddress
Set olObj = Nothing
If hismail = "David#abclimited.net" And strSubject Like "*update*" Or strSubject Like "*revision*" Then
MsgBox "Dont forget to update Drawing PDF`s if necessary", vbExclamation, "Have you updated the PDF`s?"
End If
End Sub
I have changed the address in this post but it is the same format and length.
After a little bit of digging I found a solution that should get you pointed in the right direction. This is based off of the suspicion that your problem is due to your target user not being available within the Exchange server of your organization. This solution should solve the issue, but if it doesn't it will at least give you an idea of where to look next.
First, I took the code example from this MSDN article (https://msdn.microsoft.com/en-us/VBA/Outlook-VBA/articles/obtain-the-e-mail-address-of-a-recipient) and modified it so that it returns an array of Address Users and their emails:
Private Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Private Function GetSMTPAddressesForRecipients(ByVal MailItem As Outlook.MailItem) As Variant
Dim Recipients As Outlook.Recipients
Set Recipients = MailItem.Recipients
Dim Addresses As Variant
ReDim Addresses(0 To Recipients.Count - 1, 0 To 1)
Dim Accessor As Outlook.PropertyAccessor
Dim Recipient As Outlook.Recipient
For Each Recipient In Recipients
Set Accessor = Recipient.PropertyAccessor
Dim i As Long
Addresses(i, 0) = Recipient.Name
Addresses(i, 1) = Accessor.GetProperty(PR_SMTP_ADDRESS)
i = i + 1
Next
GetSMTPAddressesForRecipients = Addresses
End Function
This will loop through all recipients within the email, and capture their names and emails, putting each one into the next spot within the array. Next, we need to use this information within your routine:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
' Note that I explicitly convert the subject to lowercase since the patterns use lowercase
Dim EmailSubject As String
EmailSubject = LCase(Item.Subject)
If EmailSubject Like "*update*" Or EmailSubject Like "*revision*" Then
Dim Addresses As Variant
Addresses = GetSMTPAddressesForRecipients(Item)
Dim i As Long
For i = LBound(Addresses, 1) To UBound(Addresses, 1)
If Addresses(i, 1) = "David#abclimited.net" Then
MsgBox "Dont forget to update Drawing PDF`s if necessary", vbExclamation, "Have you updated the PDF`s?"
Exit For
End If
Next
End If
End Sub
A couple of things to note here. First, your pattern was using lowercase for the subject, so you will want to convert the subject to lowercase so that, if you have a subject like "Update the Revision" your pattern still catches it.
Second, I put the most likely condition up front, that is, most of your email subjects will not contain "Subject" or "Revision". There's no need to then ask the server for the addresses of the recipients. Previously, your code would get the address before checking if it needed it. Its best to only ask for what we need, it makes your code easier to read, and maintain while also reducing any processing cost.
Finally, this code will loop through all addresses and not just look at the first one. By doing this, you will still trigger the alert even if he is the second, or third, or fiftieth address in the list.
I hope this helps! Here's the code in entirety:
Option Explicit
Private Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
' Note that I explicitly convert the subject to lowercase since the patterns use lowercase
Dim EmailSubject As String
EmailSubject = LCase(Item.Subject)
If EmailSubject Like "*update*" Or EmailSubject Like "*revision*" Then
Dim Addresses As Variant
Addresses = GetSMTPAddressesForRecipients(Item)
Dim i As Long
For i = LBound(Addresses, 1) To UBound(Addresses, 1)
If Addresses(i, 1) = "David#abclimited.net" Then
MsgBox "Dont forget to update Drawing PDF`s if necessary", vbExclamation, "Have you updated the PDF`s?"
Exit For
End If
Next
End If
End Sub
Private Function GetSMTPAddressesForRecipients(ByVal MailItem As Outlook.MailItem) As Variant
Dim Recipients As Outlook.Recipients
Set Recipients = MailItem.Recipients
Dim Addresses As Variant
ReDim Addresses(0 To Recipients.Count - 1, 0 To 1)
Dim Accessor As Outlook.PropertyAccessor
Dim Recipient As Outlook.Recipient
For Each Recipient In Recipients
Set Accessor = Recipient.PropertyAccessor
Dim i As Long
Addresses(i, 0) = Recipient.Name
Addresses(i, 1) = Accessor.GetProperty(PR_SMTP_ADDRESS)
i = i + 1
Next
GetSMTPAddressesForRecipients = Addresses
End Function
We've got multiple users using an existing mailbox on Outlook. Everyone who sends from the mailbox recieves the "sent items" in their own personal mailbox. I've looked in rules and cannot find anything to have the sent items appear in the group mailbox's sent items instead.
I've got the following code, but cannot work out why it's not running.
Private Sub Application_ItemSend(ByVal Item As Object, _
Cancel As Boolean)
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim strBcc As String
On Error Resume Next
strBcc = "<mailboxname>"
If Item.SendUsingAccount = "<mailboxname>" Then
Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
'Set variable objRecip (recipient) = Item.Recipients.Add (strBcc)
If Not objRecip.Resolve Then
strMsg = "Could not resolve the Bcc recipient. " & _
"Do you want to send the message?"
res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve Bcc")
If res = vbNo Then
Cancel = True
End If
End If
End If
Set objRecip = Nothing
End Sub
To have the mail sent from the mailbox account you need to do the following:
With oMailItem
Set .SendUsingAccount = oOutlook.Session.Accounts.Item(iAccount)
...
End With
Where oMailItem and oOutlook refer to your relevant objects and iAccount is the index number of the mailbox you want to use. In my case I have two mailboxes available to send from, my personal one and the group one. My personal account is first (index 1) and the group mailbox is second (index 2).
Mail Items I send using this code always move to the Sent Items folder in the group mailbox rather than my personal one.
Im creating an outlook Macro to validate an Email attachment and recipient name before sending the mail.
The recipient name can be easily validated through the ItemSend Function on the Outlook session.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim Recipients As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim i
Dim prompt As String
Set Recipients = Item.Recipients
For i = Recipients.Count To 1 Step -1
Set recip = Recipients.Item(i)
If InStr(LCase(recip), "bad#address.com") Then
prompt$ = "You sending this to this to " & Item.To & ". Are you sure you want to send it?"
If MsgBox(prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
End If
Next i
End Sub
While this helps with recipients, it does not allow to validate the attachment name before sending the mail. i.e Validate the Mail Draft. The code below helps to check for attachments present on the draft but does not help validate it.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If InStr(1, Item.Body, "attach", vbTextCompare) > 0 Then
If Item.Attachments.Count = 0 Then
answer = MsgBox("There's no attachment, send anyway?", vbYesNo)
If answer = vbNo Then Cancel = True
End If
So i tried to add item.Attachment. Name \ item.attachment.FileName but this works only if i attribute it to a outlook MailItem instead of a normal object.
Is it possible to create code to validate the attachment name for certain criteria ( name should conform to certain naming constraints ). The code has already been created and works as a normal macro and not as a session Macro.
Function Segregate_Function(Attach_Name_Pass1 As String)
Dim FullName As String
Dim Recepients As String
Region_Ext = Right(Attach_Name_Pass1, 7)
region = Left(Region_Ext, 3)
'MsgBox region
If region = "ENG" Then
Recepients = "ABC#gmail.com;XYZ#gmail.com"
Call Send_Function(Attach_Name_Pass1, Recepients)
Else
MsgBox " Not an Acceptable Attachment. Mail Could not be Generated "
End If
End Function
I would like the above code to execute when clicking on send to validate an attachment name directly, instead of having a procedural Macro running.
Do advice.
Try testing within ItemSend.
Something like this:
Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim att As attachment
Dim Attach_Name_Pass1 As String
Dim Region_Ext As String
Dim Region As String
Cancel = False
If Item.Attachments.count = 0 Then
If MsgBox("There's no attachment, send anyway?", vbYesNo) = vbNo Then Cancel = True
Else
Debug.Print Item.To
If InStr(Item.To, "ABC#gmail.com") > 0 Or InStr(Item.To, "XYZ#gmail.com") > 0 Then
For Each att In Item.Attachments
Attach_Name_Pass1 = att.DisplayName
Region_Ext = Right(Attach_Name_Pass1, 7)
Region = Left(Region_Ext, 3)
'MsgBox region
Debug.Print Region
If Region <> "ENG" Then
Cancel = True
MsgBox " Not an Acceptable Attachment. Send cancelled."
Exit For
End If
Next
End If
End If
End Sub
Newbie poster with Outlook VBA. Intermediate Excel VBA coder.
I have a VBA routine that autoforwards all incoming email to a Gmail account. It is not all my code, (modified from a blog post) but it works. I need to keep a copy of all my email received in all my accounts so I can consolidate them into one main one. In the Outlook 2010 Exchange account, all the forwarded mail gets saved in the SENT folder as a copy.
Is it possible to delete the autoforwarded copy in the SENT folder, without deleting all SENT emails? I need to keep the emails I actually respond to.
I would not have a problem using conversation mode in the INBOX, to store the replied to emails. but as it now stands, everything is duplicated due to the bcc copy in the SENT folder when I toggle Conversation mode for the INBOX.
Thanks in advance for any assistance.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim strBcc As String
On Error Resume Next
' #### USER OPTIONS ####
' address for Bcc -- must be SMTP address or resolvable
' to a name in the address book
strBcc = "bcc.hwb#gmail.com"
Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
If Not objRecip.Resolve Then
strMsg = "Could not resolve the Bcc recipient. " & _
"Do you want still to send the message?"
res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve Bcc Recipient")
If res = vbNo Then
Cancel = True
End If
End If
Set objRecip = Nothing
End Sub
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim varEntryIDs
Dim objItem
Dim myItem As MailItem
Dim i As Integer
varEntryIDs = Split(EntryIDCollection, ",")
For i = 0 To UBound(varEntryIDs)
Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))
'MsgBox (varEntryIDs(i))
Set myItem = objItem.Forward
myItem.Recipients.Add "bcc.hwb#gmail.com"
myItem.Send
'myItem.Delete
Set myItem = Nothing
Next
End Sub
See MailItem.DeleteAfterSubmit Property (Outlook)
myItem.DeleteAfterSubmit = True