Flag email going to multiple different external domains using VBA - vba

We are trying to read the domains of addresses an email is being sent to, and if there is more than one domain, confirm that the user wants to send the email. That way we don't risk confidentiality by sending an email to a wrong domain.
We developed a macro that flags all emails being sent to a different domain as external, and gives a popup box that asks "Yes or No". We want to modify to flag only if there is more than one external domain.
For example, flag #google.com, #yahoo.com and not #google.com, #google.com
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.propertyAccessor
Dim prompt As String
Dim Address As String
Dim lLen
Dim strMyDomain
Dim internal As Long
Dim external As Long
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
' non-exchange
' userAddress = Session.CurrentUser.Address
' use for exchange accounts
userAddress = Session.CurrentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress
lLen = Len(userAddress) - InStrRev(userAddress, "#")
strMyDomain = Right(userAddress, lLen)
Set recips = Item.Recipients
For Each recip In recips
Set pa = recip.propertyAccessor
Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
lLen = Len(Address) - InStrRev(Address, "#")
str1 = Right(Address, lLen)
If str1 = strMyDomain Then internal = 0
If str1 <> strMyDomain Then external = 1
Next
If internal + external = 1 Then
prompt = "This email is being sent to an External Address. Do you still wish to send?"
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
End If
End Sub
'''

Set recips = Item.Recipients
For Each recip In recips
Set pa = recip.propertyAccessor
Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
lLen = Len(Address) - InStrRev(Address, "#")
str1 = Right(Address, lLen)
dim firstexternaldomain as string
If str1 = strMyDomain Then internal = 0
If str1 <> strMyDomain Then
if len(firstexternaldomain)=0 then
firstexternaldomain = str1
else
if str1 = firstexternaldomain then internal = 0 else external = 1
end if
End if
Next
there could be some less complicated parts in your code, but if it works never change it!
I hope my suggestion works,
Max

Related

Export Recipient Mail Address instead of Name in Outlook VBA

I try to export the Mail Addresses from my SentObjekts to Excel - this works fine.
But the Outlook VBA Variable for the recipients Mail Address "To" exports the Name of the Recipient and not the Mail address. I will see the Mail Address in my Excel.
Did anybody knows how to export only the Mail address?
Dim RecipientEmailAddress As String
RecipientEmailAddress = .To
The following functions should be adaptable for what you require. A listener for new e-mail will be needed (which I assume you have), but you can then pass the MailItem into the EmailAddressInfo function which returns a 3 dimension array for the sender, To and CC addresses. I've included a test function which can be used to check this
The code should be expandable in the case of unknown e-mail types through the use of the CASE declarations
Private Const olOriginator As Long = 0, olTo As Long = 1, olCC As Long = 2, olBCC As Long = 3
Function PrintEmailAddresses(olItem As MailItem)
If olItem.Class <> olMail Then Exit Function
Dim Arr As Variant: Arr = EmailAddressInfo(olItem)
Debug.Print "Sender: " & Arr(0)
Debug.Print "To Address: " & Arr(1)
Debug.Print "CC Address: " & Arr(2)
End Function
Private Function EmailAddressInfo(olItem As MailItem) As Variant
If olItem.Class <> olMail Then Exit Function
Dim olRecipient As Outlook.Recipient
Dim ToAddress, CCAddress, Originator, email As String
With olItem
Select Case UCase(.SenderEmailType)
Case "SMTP": Originator = .SenderEmailAddress
Case Else: Originator = .Sender.GetExchangeUser.PrimarySmtpAddress
End Select
End With
For Each olRecipient In olItem.Recipients
With olRecipient
Select Case UCase(.AddressEntry.Type)
Case "SMTP": email = .Address
Case Else: email = .AddressEntry.GetExchangeUser.PrimarySmtpAddress
End Select
Select Case .Type
Case olTo: ToAddress = ToAddress & email & ";"
Case olCC: CCAddress = CCAddress & email & ";"
End Select
End With
Next
EmailAddressInfo = Array(Originator, ToAddress, CCAddress)
End Function

Send email with .SentOnBehalfOfName

I have a script that the company has been using for a while and no issues.
We switched from Outlook 2010 to Outlook 2016.
The script fills in the right information but when clicking on the send button, it bounces back to the email user's inbox saying "undelivered" and
"This message could not be sent. You do not have the permission to send the message on behalf of the specified user."
I have verified that the user has full access to that user mailbox.
Sub ForwardA()
Dim objMail As Outlook.MailItem
Dim GetSMTPAddress As String, s As String, piece As String, i As Long, j As Long
Dim olkSnd As Outlook.AddressEntry, olkExu As Outlook.ExchangeUser
Dim olNS As Outlook.NameSpace
Set olNS = Application.GetNamespace("MAPI")
Set objITEM = GetCurrentItem()
Set olkSnd = objITEM.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkExu = olkSnd.GetExchangeUser
GetSMTPAddress = olkExu.PrimarySmtpAddress
Else
GetSMTPAddress = objITEM.SenderEmailAddress
End If
Set olkSnd = Nothing
Set olkExu = Nothing
s = GetSMTPAddress
i = InStr(s, "#")
j = InStrRev(s, ".")
piece = UCase(Mid(s, i + 1, j - i - 1))
If piece = "--------" Then
piece = InputBox("----- - Enter New Company name")
End If
'MsgBox piece
Set objMail = objITEM.Forward
objMail.SentOnBehalfOfName = "orders#------.com"
objMail.To = ""
objMail.Subject = piece & ": CONFIRMATION RECEIPT OF "
objMail.BCC = ""
objMail.SendUsingAccount = olNS.Accounts.Item(1)
objMail.Display
Set objITEM = Nothing
Set objMail = Nothing
MoveToCustomerPO

Warn before sending messages outside of multiple possible internal domains?

I'm trying to check if recipients of my e-mail are in our Global Address List in Outlook 2016.
If all the recipients are internal (our GAL includes only internal addresses) then the message is released.
If at least one of the recipients are external (from outside of GAL), then I should get a warning message, which will ask if I still want to send this e-mail.
I tried this topic, but I need a solution without copying the addresses to external Excel spreadsheet.
I also worked with this solution, but our company is big, and has multiple branches all around the globe. The cited solution checks if my domain is the same with the recipients domains. The problem occurs when I'm trying to send an e-mail to people from my company, but outside my region - I'm from EMEA, and e.g. I'm sending an e-mail to PAM. Unfortunately, this solution is not enough in this moment. Because PAM is using a different domain - the warning message occurs.
The simplest way for me, would be to check the recipients in GAL, but I'm not sure if this is even possible.
Code from the second solution below:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.propertyAccessor
Dim prompt As String
Dim Address As String
Dim lLen
Dim strMyDomain
Dim internal As Long
Dim external As Long
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
' non-exchange
' userAddress = Session.CurrentUser.Address
' use for exchange accounts
userAddress = Session.CurrentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress
lLen = Len(userAddress) - InStrRev(userAddress, "#")
strMyDomain = Right(userAddress, lLen)
Set recips = Item.Recipients
For Each recip In recips
Set pa = recip.propertyAccessor
Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
lLen = Len(Address) - InStrRev(Address, "#")
str1 = Right(Address, lLen)
If str1 = strMyDomain Then internal = 1
If str1 <> strMyDomain Then external = 1
Next
If internal + external = 2 Then
prompt = "This email is being sent to Internal and External addresses. Do you still wish to send?"
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
End If
End Sub
You could replace the single internal domain with an array of domains.
Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Recipients
Dim recip As Recipient
Dim pa As propertyAccessor
Dim prompt As String
Dim Address As String
Dim lLen As Long
Dim Str1 As String
Dim arrayDomains() As Variant
Dim i As Long
Dim internalFlag As Boolean
Dim externalFlag As Boolean
Dim strExtAdd As String
arrayDomains = Array("PAM domain", "EMEA domain", "other internal domain")
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = Item.Recipients
For Each recip In recips
Set pa = recip.propertyAccessor
Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
lLen = Len(Address) - InStrRev(Address, "#")
Str1 = Right(Address, lLen)
internalFlag = False
For i = LBound(arrayDomains) To UBound(arrayDomains)
If Str1 = arrayDomains(i) Then
internalFlag = True
Exit For
End If
Next
If internalFlag = False Then
externalFlag = True
strExtAdd = strExtAdd & vbCr & Address
End If
Next
If externalFlag = True Then
prompt = "This email is being sent to external addresses. Do you still wish to send?" & strExtAdd
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
'Else
'Debug.Print "Internal addresses only."
End If
End Sub

Exclude signature from attachment look up macro

I'm working on a macro which checks the attachment name against the subject name and the domain.
At the moment there's a couple of minor issues, I don't want the macro to recognise images in the signature as an attachment. Solutions I've seen include using an if statement to work out the size, so for example only check attachments over 5kb etc.
The other issue is, if there is no attachment at all, the macro falls over! I think I need another if statement in there at the end to do an item count but I'm not sure how that alters my conditions at the end of the macro!
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim outRecips As Outlook.Recipients
Dim outRecip As Outlook.Recipient
Dim outPropAcc As Outlook.PropertyAccessor
Dim strDomain As String
Dim lngPreDom As Long
Dim lngPostDom As Long
Dim strSubject As String
Dim objAttachments As Outlook.Attachments
Dim strAttachment As String
Dim Response As String
' set domain value
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set outRecips = Item.Recipients
For Each outRecip In outRecips
Set outPropAcc = outRecip.PropertyAccessor
strDomain = outPropAcc.GetProperty(PR_SMTP_ADDRESS)
strDomain = Split(strDomain, "#")(1)
lngPreDom = InStr(strDomain, "#")
lngPostDom = InStr(strDomain, ".")
strDomain = LCase(Mid(strDomain, lngPreDom + 1, lngPostDom - lngPreDom - 1))
Exit For
Next
' set subject value
strSubject = LCase(Item.Subject)
' set attachment name
Set objAttachments = Item.Attachments
strAttachment = LCase(objAttachments.Item(1).FileName)
' if external recipient, check email contents
If strDomain <> "exampleemail" _
Then
If InStr(strSubject, strDomain) = 0 _
Or InStr(strAttachment, strDomain) = 0 _
Or InStr(strAttachment, strSubject) = 0 _
Then
Response = "Attachment/Subject do not match Recipient(s)" & vbNewLine & "Send Anyway?"
If MsgBox(Response, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Recipients") = vbNo Then
Cancel = True
End If
End If
End If
End Sub
Use the Attachment.PropertyAccessor object to read the PR_ATTACHMENT_HIDDEN property (http://schemas.microsoft.com/mapi/proptag/0x7FFE000B); if it's true it's an embedded image (usually in signatures).

How do you extract email addresses from the 'To' field in outlook?

I have been using VBA to some degree, using this code:
Sub ExtractEmail()
Dim OlApp As Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")
' Setup Namespace
Set NS = ThisOutlookSession.Session
' Display select folder dialog
Set Folder = NS.PickFolder
' Create Text File
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\mydocuments\emailss.txt", True)
' loop to read email address from mail items.
For Each Mailobject In Folder.Items
Email = Mailobject.To
a.WriteLine (Email)
Next
Set OlApp = Nothing
Set Mailobject = Nothing
a.Close
End Sub
However this gives output as the names of the email addresses and not the actual email address with the "something#this.domain".
Is there an attributte of the mailobject that will allow the email addresses and not the names to be written from the 'To' Textbox.
Thanks
Check out the Recipients collection object for your mail item, which should allow you to get the address: http://msdn.microsoft.com/en-us/library/office/ff868695.aspx
Update 8/10/2017
Looking back on this answer, I realized I did a bad thing by only linking somewhere and not providing a bit more info.
Here's a code snippet from that MSDN link above, showing how the Recipients object can be used to get an email address (snippet is in VBA):
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
It looks like, for email addresses outside of your organization, the SMTP address is hidden in emailObject.Recipients(i).Address, though it doesn't seem to allow you to distinguish To/CC/BCC.
The Microsoft code was giving me an error, and some investigating reveals that the schema page is no longer available. I wanted a semicolon-delaminated list of email addresses that were either in my Exchange organization or outside of it. Combining it with another S/O answer to convert inner-company email display names to SMTP names, this does the trick.
Function getRecepientEmailAddress(eml As Variant)
Set out = CreateObject("System.Collections.Arraylist") ' a JavaScript-y array
For Each emlAddr In eml.Recipients
If Left(emlAddr.Address, 1) = "/" Then
' it's an Exchange email address... resolve it to an SMTP email address
out.Add ResolveDisplayNameToSMTP(emlAddr)
Else
out.Add emlAddr.Address
End If
Next
getRecepientEmailAddres = Join(out.ToArray(), ";")
End Function
If the email is inside your organization, you need to convert it to an SMTP email address. I found this function from another StackOverflow answer helpful:
Function ResolveDisplayNameToSMTP(sFromName) As String
' takes a Display Name (i.e. "James Smith") and turns it into an email address (james.smith#myco.com)
' necessary because the Outlook address is a long, convoluted string when the email is going to someone in the organization.
' source: https://stackoverflow.com/questions/31161726/creating-a-check-names-button-in-excel
Dim OLApp As Object 'Outlook.Application
Dim oRecip As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
Dim oEDL As Object 'Outlook.ExchangeDistributionList
Set OLApp = CreateObject("Outlook.Application")
Set oRecip = OLApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
End Select
End If
End Function
The answers above did not work for me. I think they only work when the recipient is in the address book. The following code is also to able to lookup email addresses from outside the organisation. Additionally it makes a distinction between to/cc/bcc
Dim olRecipient As Outlook.Recipient
Dim strToEmails, strCcEmails, strBCcEmails As String
For Each olRecipient In item.Recipients
Dim mail As String
If olRecipient.AddressEntry Is Nothing Then
mail = olRecipient.Address
ElseIf olRecipient.AddressEntry.GetExchangeUser Is Nothing Then
mail = olRecipient.Address
Else
mail = olRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
Debug.Print "resolved", olRecipient.Name, mail
If olRecipient.Type = Outlook.OlMailRecipientType.olTo Then
strToEmails = strToEmails + mail & ";"
ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olCC Then
strCcEmails = strCcEmails + mail & ";"
ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olBCC Then
strBCcEmails = strBCcEmails + mail & ";"
End If
Next
Debug.Print strToEmails
Debug.Print strCcEmails
Debug.Print strBCcEmails
Another code alternative (based initially on the answer by #andreasDL) which should be able to be used...
Pass in a MailItem to the EmailAddressInfo function to get an array of the Sender, To and CC fields from the message
Private Const olOriginator As Long = 0, olTo As Long = 1, olCC As Long = 2, olBCC As Long = 3
'BCC addresses are not included within received messages
Function PrintEmailAddresses(olItem As MailItem)
If olItem.Class <> olMail Then Exit Function
Dim Arr As Variant: Arr = EmailAddressInfo(olItem)
Debug.Print "Sender: " & Arr(olOriginator)
Debug.Print "To Address: " & Arr(olTo)
Debug.Print "CC Address: " & Arr(olCC)
End Function
Private Function EmailAddressInfo(olItem As MailItem) As Variant
If olItem.Class <> olMail Then Exit Function
On Error GoTo ExitFunction
Dim olRecipient As Outlook.Recipient
Dim olEU As Outlook.ExchangeUser
Dim olEDL As Outlook.ExchangeDistributionList
Dim ToAddress, CCAddress, Originator, email As String
With olItem
Select Case UCase(.SenderEmailType)
Case "SMTP": Originator = .SenderEmailAddress
Case Else
Set olEU = .Sender.GetExchangeUser
If Not olEU Is Nothing Then Originator = olEU.PrimarySmtpAddress
End Select
End With
For Each olRecipient In olItem.Recipients
With olRecipient
Select Case .AddressEntry.AddressEntryUserType
Case olSmtpAddressEntry 'OlAddressEntryUserType.
email = .Address
Case olExchangeDistributionListAddressEntry, olOutlookDistributionListAddressEntry
Set olEDL = .AddressEntry.GetExchangeDistributionList
email = IIf(Not olEDL Is Nothing, olEDL.PrimarySmtpAddress, "")
Case Else
Set olEU = .AddressEntry.GetExchangeUser
email = IIf(Not olEU Is Nothing, olEU.PrimarySmtpAddress, "")
End Select
If email <> "" Then
Select Case .Type
Case olTo: ToAddress = ToAddress & email & ";"
Case olCC: CCAddress = CCAddress & email & ";"
End Select
End If
End With
Next
EmailAddressInfo = Array(Originator, ToAddress, CCAddress)
ExitFunction:
End Function
This is what worked for me with Outlook 2019. Use your internal domain name(s). Might need some tweaking yet - not heavily tested. Place code in the ThisOutlookSession module. (Updated to handle Exchange distribution lists 7/31/20.)
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xMailItem As Outlook.MailItem
Dim xRecipients As Outlook.Recipients
Dim OutRec As Outlook.Recipient
Dim OutTI As Outlook.TaskItem
Dim i As Long
Dim j As Long
Dim xOKCancel As Integer
Dim sMsg As String
Dim oMembers As AddressEntries
Dim oMember As AddressEntry
Dim sDomains As String
Dim sTemp As String
On Error Resume Next
If Item.Class <> olMail Then GoTo ExitCode
sDomains = "#test1.com #test2.com"
Set xMailItem = Item
Set xRecipients = xMailItem.Recipients
'Loop through email recipients to get email addresses
For i = xRecipients.Count To 1 Step -1
'If we have a text address entry in the email
If InStr(xRecipients.Item(i).AddressEntry, "#") > 0 Then
sTemp = xRecipients.Item(i).AddressEntry
If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "#"), 254))) <= 0 Then
sMsg = sMsg & sTemp & vbCrLf
End If
Else
Select Case xRecipients.Item(i).AddressEntry.DisplayType
Case Is = olDistList
Set oMembers = xRecipients.Item(i).AddressEntry.Members
For j = oMembers.Count To 1 Step -1
Set oMember = oMembers.Item(j)
sTemp = oMember.GetExchangeUser.PrimarySmtpAddress
If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "#"), 254))) <= 0 Then
sMsg = sMsg & sTemp & vbCrLf
End If
Set oMember = Nothing
Next j
Set oMembers = Nothing
Case Is = olUser
Set OutTI = Application.CreateItem(3)
OutTI.Assign
Set OutRec = OutTI.Recipients.Add(xRecipients.Item(i).AddressEntry)
OutRec.Resolve
If OutRec.Resolved Then
sTemp = OutRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "#"), 254))) <= 0 Then
sMsg = sMsg & sTemp & vbCrLf
End If
End If
Set OutTI = Nothing
Set OutRec = Nothing
Case Else
MsgBox "Unaccomodated AddressEntry.DisplayType."
GoTo ExitCode
End Select
End If
Next i
'Display user message
If Len(sMsg) > 0 Then
sMsg = "This email is addressed to the following external Recipients:" & vbCrLf & vbCrLf & sMsg
xOKCancel = MsgBox(sMsg, vbOKCancel + vbQuestion, "Warning")
If xOKCancel = vbCancel Then Cancel = True
End If
End Sub