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
Related
I am writing a VBScript to extract CC from the email. When I extract the cc, instead of an email address, it shows the email name of the person. I had same issue while I was extracting the "from" address. I checked whether the email address type of the from the person (.SenderEmailType) is SMTP or EX and was able to fetch the email address instead of email name. I don't know how to do the same for CC. I have checked online, it is written to loop through "Mailitems.Recipent". I am new to vbscript to I am not sure how to do this. Currently I am using .CC object to get the cc detail.
Set Arg = WScript.Arguments
dim item1
dim objsubject
dim intcount
Dim i
dim savename
dim vTextFile
dim filename
dim extension
Dim t
Dim Itimestamp
dim savefolder
Dim vSenderEmailAddress
Dim vCcEmailAddress
Dim vFlagTextFileCreate
vFlagTextFileCreate = True
savefolder = "C:\Users\tgssupport\Documents\Automation Anywhere Files\Automation Anywhere\My Scripts\Retro Pricing\junk"
vTextFile = savefolder & "\File Report.txt"
vFlagExcelAttachmentFound = False
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then 'Could not get instance of Outlook, so create a new one
Err.Clear
Set olApp = CreateObject("Outlook.Application")
End If
on error goto 0
Set olns = olApp.GetNameSpace("MAPI")
olns.logon "Outlook",,False,True
'6 is for Inbox
Set objFolder = olns.GetDefaultFolder(6)
For each item1 in objFolder.Items
if item1.Unread=true then
objsubject = item1.subject
vCcEmailAddress = item1.CC
If item1.SenderEmailType = "SMTP" Then
vSenderEmailAddress = item1.SenderEmailAddress
ElseIf item1.SenderEmailType = "EX" Then
vSenderEmailAddress = item1.Sender.GetExchangeUser.PrimarySmtpAddress
End If 'If item1.SenderEmailType
msgbox vCcEmailAddress.
msgbox vSenderEmailAddress.
end if 'if item1.Unread=true
Next
olns.logoff
Set olns = Nothing
Set olApp = Nothing
WScript.Quit
With item1.Recipients
For i = 1 To .Count
If .Item(i).Type = OlMailRecipientType.olCC Then
vCcEmailAddress = .Item(i).Address
Exit For
End If
Next i
End With
Set objFolder = olns.GetDefaultFolder(6)
For each item1 in objFolder.Items
For Each RecipientObject In item1.Recipients
If RecipientObject.Type = 2 Then
msgbox RecipientObject.Address
End if
Next
Next
I'm reading Outlook Inbox and Sent folder emails for a given address and populating an Access table. My routine isn't picking up the "Reply" emails. I assumed they would be in the sent folder. I don't have any subfolders at this time. Any thoughts on what I'm missing or don't understand? This is my first venture into reading Outlook data.
Sub GetFromInbox(strInboxSent As String, strForAddress As String)
Dim olFolderInboxSent As Integer
Select Case strInboxSent
Case "InBox"
olFolderInboxSent = 6 '6 = InBox, Sent = 5
Case "Sent"
olFolderInboxSent = 5
End Select
Dim olApp As Object, olNs As Object
Dim oRootFldr As Object ' Root folder to start
Dim lCalcMode As Long
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set oRootFldr = olNs.GetDefaultFolder(olFolderInboxSent)
GetFromFolder oRootFldr, strForAddress, olFolderInboxSent
Set oRootFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Private Sub GetFromFolder(oFldr As Object, strForAddress As String, intInboxSent As Integer)
'Load Worktable with sent emails
Dim cmd As ADODB.Command
Dim rst As ADODB.Recordset
Set cmd = New ADODB.Command
cmd.ActiveConnection = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.LockType = adLockOptimistic
cmd.CommandText = "Select * From wtblEmails"
rst.Open cmd
Dim oItem As Object, oSubFldr As Object
' Process all mail items in this folder
For Each oItem In oFldr.Items
Debug.Print TypeName(oItem)
If TypeName(oItem) = "MailItem" Then
With oItem
Select Case intInboxSent
Case 6
If .SenderEmailAddress = strForAddress Then
'Debug.Print .Subject, .SenderName, .SenderEmailAddress, .EntryID
rst.AddNew
rst!weDate = .CreationTime
rst!weRcvdSent = "R"
rst!weWith = .SenderEmailAddress
rst!weSubject = .Subject
rst!weBody = .Body
rst!weid = .EntryID
rst.Update
End If
Case 5
If .To = strForAddress Then
'Debug.Print .Subject, .SenderName, .SenderEmailAddress, .EntryID
rst.AddNew
rst!weDate = .CreationTime
rst!weRcvdSent = "S"
rst!weWith = .To
rst!weSubject = .Subject
rst!weBody = .Body
rst!weid = .EntryID
rst.Update
End If
End Select
End With
End If
Next
' Recurse all Subfolders
For Each oSubFldr In oFldr.Folders
GetFromFolder oSubFldr, strForAddress, intInboxSent
Next
End Sub
Here is what I found that works. The list of recipient address for a sent email are found here. For each email item, I call this function to see if the address I'm looking for was in the list of recipients.
Public Function fncWasMailSentTo(mail As Outlook.MailItem, strAddress As String) As Boolean
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
fncWasMailSentTo = False
For Each recip In recips
Set pa = recip.PropertyAccessor
'Debug.Print recip.Name & " SMTP=" & pa.GetProperty(PR_SMTP_ADDRESS)
If pa.GetProperty(PR_SMTP_ADDRESS) = strAddress Then
fncWasMailSentTo = True
Exit For
End If
Next
End Function
I pull the Subject, received date and sender's name with the following code:
Set InboxSelect = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
i = 0: EmailCount = 0
EmailCount = InboxSelect.Items.Count
While i < EmailCount
i = i + 1
blastRow = Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
LastRow = Sheets("Body").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
With InboxSelect.Items(i)
MsgBox (SenderEmailAddress)
'If .senderemailaddress = "*#somethingSpecific.co.uk" Then
'EmailCount = EmailCount + 1
Sheets("Import Data").Range("A" & blastRow).Formula = .SenderName
Sheets("Import Data").Range("B" & blastRow).Formula = Format(.ReceivedTime, "dd/mm/yyyy")
Sheets("Import Data").Range("C" & blastRow).Formula = .Subject
Sheets("Body").Range("A" & LastRow).Formula = .Body
'End If
End With
Wend
What I'm trying to achieve now is an if statement that will say "If the sender's email address is 'anything#somethingSpecific.co.uk' then execute that code.
I've tried SenderEmailAddress but it returns blank when tested in a message box.
EDIT: /O=*SET1*/OU=FIRST ADMINISTRATIVE GROUP/CN=RECIPIENTS/CN=*VARIABLE1* is now being returned in the immediate window every time with the below code:
Set InboxSelect = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
i = 0: EmailCount = 0
EmailCount = InboxSelect.Items.Count
While i < EmailCount
For Each Item In InboxSelect.Items
Debug.Print Item.senderemailaddress
If Item.senderemailaddress = "/O=SET1/OU=FIRST ADMINISTRATIVE GROUP/CN=RECIPIENTS/CN=*" Then
i = i + 1
blastRow = Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
LastRow = Sheets("Body").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
With InboxSelect.Items(i)
Sheets("Import Data").Range("A" & blastRow).Formula = .SenderName
Sheets("Import Data").Range("B" & blastRow).Formula = Format(.ReceivedTime, "dd/mm/yyyy")
Sheets("Import Data").Range("C" & blastRow).Formula = .Subject
'PASTING BODY IS SLOW
Sheets("Body").Range("A" & LastRow).Formula = .Body
'End If
End With
End If
Next Item
Wend
What I've attempted to do is use a wildcard symbol (the *) to act as the variation in the returned message but that hasn't worked, is there a better way to do this?
An example of when using the SenderEmailAddress property returns the e-mail string as required.
Dim outlookApp As outlook.Application, oOutlook As Object
Dim oInbox As outlook.Folder, oMail As outlook.MailItem
Set outlookApp = New outlook.Application
Set oOutlook = outlookApp.GetNamespace("MAPI")
Set oInbox = oOutlook.GetDefaultFolder(olFolderInbox)
For Each oMail In oInbox.Items
Debug.Print oMail.SenderEmailAddress
Next oMail
EDIT:
The issue is that what the .SenderEmailAddress property is returning the EX address, whereas we want the SMTP address. For any internal e-mail addresses, it will return the EX type address.
To get the SMTP address from an internal e-mail, you can use the below.
Dim outlookApp As Outlook.Application, oOutlook As Object
Dim oInbox As Outlook.Folder, oMail As Outlook.MailItem
Dim strAddress As String, strEntryId As String, getSmtpMailAddress As String
Dim objAddressentry As Outlook.AddressEntry, objExchangeUser As Outlook.ExchangeUser
Dim objReply As Outlook.MailItem, objRecipient As Outlook.Recipient
Set outlookApp = New Outlook.Application
Set oOutlook = outlookApp.GetNamespace("MAPI")
Set oInbox = oOutlook.GetDefaultFolder(olFolderInbox)
For Each oMail In oInbox.Items
If oMail.SenderEmailType = "SMTP" Then
strAddress = oMail.SenderEmailAddress
Else
Set objReply = oMail.Reply()
Set objRecipient = objReply.Recipients.Item(1)
strEntryId = objRecipient.EntryID
objReply.Close OlInspectorClose.olDiscard
strEntryId = objRecipient.EntryID
Set objAddressentry = oOutlook.GetAddressEntryFromID(strEntryId)
Set objExchangeUser = objAddressentry.GetExchangeUser()
strAddress = objExchangeUser.PrimarySmtpAddress()
End If
getSmtpMailAddress = strAddress
Debug.Print getSmtpMailAddress
Next oMail
If the e-mail is already SMTP it will just use the .SenderEmailAddress property to return the address. If the e-mail is EX then it will find the SMTP address by using the .GetAddressEntryFromID() Method.
The above is modified code from what I found on this answer. Here is also a link with how to do this within C#.
Public Function GetSenderAddrStr(objMail As Outlook.MailItem) As String
If objMail.SenderEmailType = "SMTP" Then
GetSenderAddrStr = objMail.SenderEmailAddress
Else
GetSenderAddrStr = objMail.Sender.GetExchangeUser().PrimarySmtpAddress
End If
End Function
In most cases, the sender's SMTP address will be available in a separate property, you can access it using MailItem.PropertyAccessor - take a look at an existing message using OutlookSpy (I am its author) - click IMessage button.
Otherwise you can use ExchangeUser.PrimarySmtpAddress
Off the top of my head:
on error resume next 'PropertyAccessor can raise an exception if a property is not found
if item.SenderEmailType = "SMTP" Then
strAddress = item.SenderEmailAddress
Else
'read PidTagSenderSmtpAddress
strAddress = item.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001F")
if Len(strAddress) = 0 Then
set objSender = item.Sender
if not (objSender Is Nothing) Then
'read PR_SMTP_ADDRESS_W
strAddress = objSender.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001F")
if Len(strAddress) = 0 Then
'last resort
set exUser = objSender.GetExchangeUser
if not (exUser Is Nothing) Then
strAddress = exUser.PrimarySmtpAddress
End If
End If
End If
En If
End If
Cant you just use send keys to force "Control+k" in outlook? Seems like this would solve your issue and probably make for an easy slice of code.
try adding this somewhere?
Application.SendKeys("^k") 'i believe this is correct syntax, never used this yet but i think it works
I ended up doing
varTest = Item.senderemailaddress
If InStr(varTest, "BE WISER INSURANCE") > 0 Then
which detected the set section that wouldn't be in any emails I didn't want. Thanks very much for your help, #Iturner!
In most cases, the sender's SMTP address will be available on the mesage itself in a separate property (PidTagSenderSmtpAddress = 0x5D01001F, DASL name "http://schemas.microsoft.com/mapi/proptag/0x5D01001F"), you can access it using MailItem.PropertyAccessor - take a look at an existing message using OutlookSpy (I am its author) - click IMessage button.
Otherwise you can use ExchangeUser.PrimarySmtpAddress: it is more expensive than reading the PidTagSenderSmtpAddress property. PidTagSenderSmtpAddress will also work if ExchangeUser fails (which can happen if the user was deleted from GAL or if you are looking at the message in a profile different from the one where the message was created)
Off the top of my head:
on error resume next 'PropertyAccessor can raise an exception if a property is not found
if item.SenderEmailType = "SMTP" Then
strAddress = item.SenderEmailAddress
Else
'read PidTagSenderSmtpAddress
strAddress = item.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001F")
if Len(strAddress) = 0 Then
set objSender = item.Sender
if not (objSender Is Nothing) Then
'read PR_SMTP_ADDRESS_W
strAddress = objSender.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001F")
if Len(strAddress) = 0 Then
'last resort
set exUser = objSender.GetExchangeUser
if not (exUser Is Nothing) Then
strAddress = exUser.PrimarySmtpAddress
End If
End If
End If
En If
End If
I have a user who wants to redirect any email to other people in their department so that when that person replies to the email it will go back to the person who originally sent it.
I am trying to make VBA code to forward all emails in a specified folder and change the reply to address so that they don't have to manually put it in every time.
Sub SendFolder()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
Dim ObjMail As Outlook.MailItem
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set MyFolder = Application.Session.Folders("me#us.com").Folders("test")
For i = MyFolder.Items.Count To 0 Step -1
Set ObjMail.Subject = MyFolder.Itmes(i).Subject
Set ObjMail.ReplyRecipients = MyFolder.Itmes(i).ReplyRecipients
Set ObjMail.Body = MyFolder.Itmes(i).Body
Set ObjMail.Attachments = MyFolder.Itmes(i).Attachments
Set ObjMail.BodyFormat = MyFolder.Itmes(i).BodyFormat
Set ObjMail.To = "test#us.com"
ObjMail.Send
Next
End Sub
You are missing
Set ObjMail = Application.CreateItem(olMailItem)
Then your code would become
With ObjMail
.Subject = MyFolder.Itmes(i).Subject
.ReplyRecipients = MyFolder.Items(i).ReplyRecipients
.Body = MyFolder.Items(i).Body
.Attachments = MyFolder.Items(i).Attachments
.BodyFormat = MyFolder.Items(i).BodyFormat
.To = "test#us.com"
.Send
End with
It it runs now, the ReplyTo does not change.
You will want to set the ObjMail's ReplyRecipients property
Something like .ReplyRecipients.Add MyFolder.Items(i).SenderEmailAddress
To simplify the issue, .Forward the mail as is, and set only the ReplyRecipients property.
Check out this alternative. The mail is sent as an attachment. The receiver automatically replies to the original sender.
Untested
Sub SendFolderItemsAsAttachments()
' Run this VBA code while in Outlook
Dim MyFolder As MAPIFolder
Dim notMyItems as Items
Dim notReplyingToMe as mailitem
Dim i as long
Set MyFolder = Application.Session.Folders("me#us.com").Folders("test")
Set notMyItems = MyFolder.Items
For i = notMyItems.Count To 1 Step -1
If TypeOf notMyItems(i) Is MailItem Then
Set notReplyingToMe = Application.CreateItem(olMailItem)
With notReplyingToMe
.Subject = notMyItems(i).Subject & " - " & _
notMyItems(i).SenderName
.HTMLBody = "Redirecting for your action."
.Attachments.Add notMyItems(i), olEmbeddeditem
.To = "test#us.com"
.Send
End With
notMyItems(i).Delete
End If
Next
Set MyFolder = = Nothing
Set notMyItems = Nothing
Set notReplyingToMe = Nothing
End Sub
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