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.
Related
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
I am sending an email using the QTP outlook object model.
Here is the piece of code.
'Create an object of type Outlook
Set objOutlook = CreateObject("Outlook.Application")
Set myMail = objOutlook.CreateItem(0)
'Set the email properties
myMail.To = "some_mail_id#gmail.com"
myMail.CC = "some_mail_id_2#gmail.com; some_other_mail#yahoo.com" 'Sending mails to multiple ids
myMail.BCC = "" 'If BCC is not required, then this line can be omitted
myMail.Subject = "Sending mail from MS Outlook using QTP"
myMail.Body= "Test Mail Contents"
myMail.Attachments.Add("D:\Attachment.txt") 'Path of the file to be attached
'Send the mail
myMail.Send
Now I needed to retrieve the sender email address & store it in an environment variable. myMail.Sender or myMail.sendermailaddres both of them are not working me.
The following code will give you the first email address the user you're connected to Outlook has access to:
objOutlook.Session.Accounts.Item(0)
I use a loop to find the account I want to send from like this:
iAccount = 0
For iLoop = 1 To oOutlook.Session.Accounts.Count
If UCase(Trim(oOutlook.Session.Accounts.Item(iLoop))) = UCase(Trim(EmailData("SendFrom"))) Then
iAccount = iLoop
Exit For
End If
Next
where EmailData is a Dictionary object containing the items I'm using for the mail item. When creating the mail item I use Set oMailItem.SendUsingAccount = oOutlook.Session.Accounts.Item(iAccount) to specify the account it should be sent from.
I have a large number of forwarding email addresses which are all set to forward to the same email account. I find this is useful because if a business is hacked and my email address is stolen then I only have the change the email address for that business. For example, "amazon#mydomain.com", "ebay#mydomain.com" and "facebook#mydomain.com" would all be forwarded to "mailbox#mydomain.com".
When I want to send an email to the business, I have to go into Outlook and change the account set up to have the forwarding email address as the email address. I find this a nuisance. I know I can change who the email is from when I write it, but then the recipient sees "J Smith on behalf of newaddress#mydomain.com". I would rather it just showed the address I am using in the from field, as it does if I go into the account set up and change the email address there.
It would be nice to have a macro set up which asked me which email address I wanted to use and then sent the email for me. I have looked up how to change email account details in VBA, but it looks as if the details are all read-only. Is there a way to change my "from" email address cleanly? Or even setting up a new email account in VBA and deleting it immediately after sending it?
Try creating a userform with a combobox and a button on it. Load all your available accounts into the combobox to be able to select from it:
Private Sub UserForm_Initialize()
Dim acc As Account
For Each acc In ThisOutlookSession.Session.Accounts
Me.ComboBox1.AddItem acc.UserName
Next acc
End Sub
Then add some code to the button that selects the proper account:
Dim objApp As Outlook.Application
Dim objMail As Outlook.MailItem
Set objApp = ThisOutlookSession.Application
Set objMail = objApp.CreateItem(olMailItem)
With objMail
.To = "lala#lala.com"
.CC = ""
.BCC = ""
.Subject = "Test"
.Body = "Test"
Dim i As Integer
For i = 1 To ThisOutlookSession.Session.Accounts.Count Step 1
If ThisOutlookSession.Session.Accounts.Item(i).UserName = Me.ComboBox1.Value Then
.SendUsingAccount = ThisOutlookSession.Session.Accounts.Item(i)
End If
Next i
.Display
End With
Maybe there is an event that is called when you are creating a new email, otherwise you have to add a button or something to bring the form up.
I had this exact same problem and ended up being able to solve it by installing Outlook Redemption and using the following script...
' Redemption code below. Must install Redemption to work.
' http://www.dimastr.com/redemption/faq.htm#14
Dim sItem, Tag
Set sItem = CreateObject("Redemption.SafeMailItem")
sItem.Item = oMailItem
Tag = sItem.GetIDsFromNames("{00020386-0000-0000-C000-000000000046}", "From")
Tag = Tag Or &H1E 'the type is PT_STRING8
sItem.Fields(Tag) = GetHashedReply(oMailItem)
Tag = sItem.GetIDsFromNames("{00020386-0000-0000-C000-000000000046}", "Sender")
Tag = Tag Or &H1E 'the type is PT_STRING8
sItem.Fields(Tag) = GetHashedReply(oMailItem)
sItem.Subject = sItem.Subject 'to trick Outlook into thinking that something has changed
sItem.Save
...where oMailItem is a normal Outlook MailItem that you can get with CreateItem() or get passed to you in the ItemSend() parameters.
I've written a script that forwards incoming emails to the right people based on the contents of an excel spreadsheet.
The problem is it that does this by putting the name of the addressee into the .To field of the message (ie John Smith - not john.smith#example.com), and then looking up the actual address when I invoke the .Send method, Outlook seems to decide to sometimes look up the contacts email address via the "LinkedIn Social Connector".
How do I force it to look up the person's email address in the "Global Address List"?
You can get the address from the GAL rather letting Outlook determine it.
From the example here http://msdn.microsoft.com/en-us/library/office/ff869721(v=office.15).aspx
Untested code
Option Explicit
Sub DemoAE_ToName
Dim colAL As Outlook.AddressLists
Dim oAL As Outlook.AddressList
Dim colAE As Outlook.AddressEntries
Dim oAE As Outlook.AddressEntry
Dim oExUser As Outlook.ExchangeUser
Set colAL = Application.Session.AddressLists
For Each oAL In colAL
'Address list is an Exchange Global Address List
If oAL.AddressListType = olExchangeGlobalAddressList Then
Set colAE = oAL.AddressEntries
For Each oAE In colAE
' no distribution lists
If oAE.AddressEntryUserType = _
olExchangeUserAddressEntry _
Or oAE.AddressEntryUserType = _
olExchangeRemoteUserAddressEntry Then
If oAE.Name = "John Smith" then
Set oExUser = oAE.GetExchangeUser
Debug.Print (oExUser.PrimarySmtpAddress)
end if
End If
Next
End If
Next
End Sub
You can set up a function to pass ToName and return oExUser.PrimarySmtpAddress
Rather than
For Each oAL In colAL
If oAL.AddressListType = olExchangeGlobalAddressList Then
You should be able to drop some code with
Set oAL = Application.Session.AddressLists("Global Address List")
Edit: Re: Comments - Tough crowd.
Edit 2: Appears Restrict is not available
Tested Code where the address is retrieved when the name is known.
Sub AddressEntry_DirectAccess()
Dim oNS As Namespace
Dim oExUser As exchangeUser
Set oNS = Application.GetNamespace("MAPI")
Set oExUser = oNS.AddressLists("Global Address List").AddressEntries("Last, First").GetExchangeUser()
If Not oExUser Is Nothing Then
Debug.Print oExUser.name & ": " & oExUser.PrimarySmtpAddress
End If
End Sub
Firstly, you can specify the right name resolution order in Outlook if you hit Ctrl+Shift+B, Tools | Options.
If you were using C++ or Delphi, you could use Extended MAPI: retrieve the GAL's IABContainer interface and apply PR_ANR restriction.
If you using Redemption (I am its author) is an option, you can use RDOSession.AddressBook.GAL to retrieve the GAL container, then use RDOAddressList.ResolveName to resolve against that particular container only.
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.