I'm trying to get the "Manager" of a specific person (and hopefully iterate for a targeted list after). How to do this for a specific email address and not the Global Address List?
Dim appOL As Outlook.Application ' Object
Dim oGAL As Outlook.AddressEntries ' .NameSpace Object
Dim oContact As Outlook.AddressEntry ' Object
Dim oUser As ExchangeUser ' Object
Set appOL = New Outlook.Application ' CreateObject("Outlook.Application")
Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries("first.last#email.com")
oContact = oGAL.Item(1)
MsgBox oContact.Manager
Replace the lines
Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries("first.last#email.com")
oContact = oGAL.Item(1)
with the following (assuming you are working with a selected message in Outlook):
if appOL.ActiveExplorer.Selection.Count > 0 Then
set msg = appOL.ActiveExplorer.Selection(1)
set sender = msg.Sender
if Not (sender is null) Then
set manager = sender.Manager
End If
End If
If you are working with an one-off name, use something like
set recip = appOL.Session.CreateRecipient("The name to resolve")
if recip.Resolve Then
set manager = recip.AddressEntry.Manager
End If
Related
How could I get, with VBA Excel, the Outlook properties of a single contact for whom I have the User Principal Name?
I am interested in the tab labelled "E-mail Addresses".
I managed to get the PrimarySMTP property, but I would like to get the list of all addresses listed there. The 'alias' property gives me one entry, while there are several others.
This is what I did to get the distribution list memberships:
Dim objExchUsr As ExchangeUser
Dim myolApp As Outlook.Application
Dim myNameSpace As Namespace
Dim MyAddrList As AddressList
Dim myRecipient As Outlook.Recipient
Dim oDistListEntries As Outlook.AddressEntries
Dim oAE As Outlook.AddressEntry
Set myolApp = CreateObject("Outlook.Application")
Set myNameSpace = myolApp.GetNamespace("MAPI")
Set MyAddrList = myNameSpace.addressLists("Global Address List")
Set myRecipient = myNameSpace.CreateRecipient(strDisplayname)
myRecipient.Resolve
If myRecipient.Resolved Then
Set objExchUsr = myRecipient.AddressEntry.GetExchangeUser
Set oDistListEntries = objExchUsr.GetMemberOfList
For Each oAE In oDistListEntries
If oAE.AddressEntryUserType = olExchangeDistributionListAddressEntry Then
<Do something with the distribution lists: not relevant to this problem>
End If
Next
End If
With this code I get the information shown in the tab 'Member Of' of the Outlook Properties.
How do I get the information that is shown in the tab 'E-mail Addresses'?
Here is the code you could use:
Const PR_EMS_AB_PROXY_ADDRESSES As String = _
"http://schemas.microsoft.com/mapi/proptag/0x800F101F"
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
addresses = _
NS.CurrentUser.AddressEntry.PropertyAccessor.GetProperty(PR_EMS_AB_PROXY_ADDRESSES)
You need to read the PR_EMS_AB_PROXY_ADDRESSES MAPI property (DASL name "http://schemas.microsoft.com/mapi/proptag/0x800F101F") using AddressEntry.PropertyAccessor.GetProperty. You will get back an array of proxy addresses prefixed with the address type (e.g. "EX:" or "SMTP:")
I get the exchange online addresses from users, but I want to convert or somehow get the SMTP Address of them.
I am not sure how to get the SMTP Address from Email1Address.
Set objOL = CreateObject("Outlook.Application")
Set objNS = objOL.GetNamespace("MAPI")
Set objContactsFolder = objNS.GetDefaultFolder(olFolderContacts)
Set objItems = objContactsFolder.Items
For Each obj In objItems
'Test for contact and not distribution list
If obj.Class = olContact Then
Set objContact = obj
With objContact
If .Email1Address <>"" Then
'I want to add the SMTP-Address after the .LastNameAndFirstName of a User
strFileAs = .LastNameAndFirstName
.Email1DisplayName= strFileAs
.Save
End If
End With
End If
Err.Clear
Next
I used this for the email object, see if you can implement it:
dim email as string
If myItem.SenderEmailType = "EX" Then
email = myItem.Sender.GetExchangeUser.PrimarySmtpAddress
Else
email = myItem.SenderEmailAdress
End If
I am trying to update the contact list from the GAL.
The system for updating a contact list is that my macro deletes all the contacts in a given folder then adds contacts from the GAL where the contacts are always up to date. This creates the problem that if you add home address or personal phone to the contact you lose them once you update the contact list.
I have a macro to look in the GAL for contacts that match a specific requirement (our office location).
Now the tricky part
If a contact is (based on full name) already in my contact list then I want to update all company dedicated fields, (such as: Company name, position and so on) BUT to leave all other fields as they are.
If the contact is not in my contact list: Add it - WORKS
If a contact in my contact list has not been matched with anything from the GAL (means the person left the company) then delete all company dedicated fields (same as in 1).
My code (adds a contact based on location)
Sub GetAllGALMembers()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olGAL As Outlook.AddressList
Dim olEntry As Outlook.AddressEntries
Dim olMember As Outlook.AddressEntry
Dim objItem As Outlook.ContactItem
Dim myContacts As Outlook.MAPIFolder
Dim myFolder As MAPIFolder
Dim myItems As Items
Set mySession = New Outlook.Application
Set myNS = mySession.GetNamespace("MAPI")
Set myContacts = myNS.GetDefaultFolder(olFolderContacts)
Set myFolder = myContacts.Folders("Prague")
Set myItems = myFolder.Items
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olGAL = olNS.GetGlobalAddressList()
Set olEntry = olGAL.AddressEntries
On Error Resume Next
' loop through dist list and extract members
Dim i As Long
For i = 1 To olEntry.Count
Set olMember = olEntry.Item(i)
If olMember.AddressEntryUserType = olExchangeUserAddressEntry Then
strLocation = olMember.GetExchangeUser.OfficeLocation
If strLocation = "PRG" Then
Set objItem = olApp.CreateItem(olContactItem)
With objItem
.firstName = olMember.GetExchangeUser.firstName
.Last = olMember.GetExchangeUser.lastName
.FullName = olMember.GetExchangeUser.Name
.Email1Address = olMember.GetExchangeUser.PrimarySmtpAddress
.BusinessTelephoneNumber = olMember.GetExchangeUser.BusinessTelephoneNumber
.MobileTelephoneNumber = olMember.GetExchangeUser.MobileTelephoneNumber
.CompanyName = olMember.GetExchangeUser.CompanyName
.Email2DisplayName = olMember.GetExchangeUser.DisplayType
.Save
End With
End If
End If
Next i
End Sub
Look at this from the other side, match entries in your contact list to the GAL https://msdn.microsoft.com/en-us/library/office/ff869448.aspx.
Set myAddressEntry = myAddressList.AddressEntries(index)
This also accepts a string so instead of an index pass the string you see in (display) name to get back a match or a close entry if there is no match.
I am trying to extract email addresses of all emails in my Outlook inbox. I found this code on the Internet.
Sub GetALLEmailAddresses()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
''' Requires reference to Microsoft Scripting Runtime
Dim dic As New Dictionary
Dim objItem As Object
''Set objFolder = Application.ActiveExplorer.Selection
Set objFolder = Application.GetNamespace("Mapi").PickFolder
For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
If Not dic.Exists(strEmail) Then
strEmails = strEmails + strEmail + vbCrLf
dic.Add strEmail, ""
End If
I am using outlook 2007. When I run this code from the Outlook Visual Basic Editor with F5 I get an error on the following line.
Dim dic As New Dictionary
"user defined type not defined"
I have provided updated code below
to dump the Inbox email addresses to a CSV file "c:\emails.csv" (the current code provides no "outlook" for the collected addresses
the code above works on a selected folder rather than Inbox as per your request
[Update: For clarity this is your old code that uses "early binding", setting this reference is unnecessary for my updated code below which uses "late binding"]
Part A: Your existing code (early binding)
In terms of the error you received:
The code sample aboves uses early binding, this comment "Requires reference to Microsoft Scripting Runtime" indciates that you need to set the reference
Goto the Tools menu
Select 'References'
check "Microdoft Scripting Runtime"
Part B: My new code (late binding - setting the reference is unnecessary)
Working Code
Sub GetALLEmailAddresses()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
Dim objDic As Object
Dim objItem As Object
Dim objFSO As Object
Dim objTF As Object
Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile("C:\emails.csv", 2)
Set objFolder = Application.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
If Not objDic.Exists(strEmail) Then
objTF.writeline strEmail
objDic.Add strEmail, ""
End If
End If
Next
objTF.Close
End Sub
export the file to C:\Users\Tony\Documents\sent file.CSV
Then use ruby
email_array = []
r = Regexp.new(/\b[a-zA-Z0-9._%+-]+#[a-zA-Z0-9.-]+\.[a-zA-Z]{2,4}\b/)
CSV.open('C:\Users\Tony\Documents\sent file.CSV', 'r') do |row|
email_array << row.to_s.scan(r)
end
puts email_array.flatten.uniq.inspect
Here's an updated version for those using Exchange. It converts Exchange format addresses to normal email addresses (with the # symbol).
' requires reference to Microsoft Scripting Runtime
Option Explicit
Sub Write_Out_Email_Addresses()
' dictionary for storing email addresses
Dim email_list As New Scripting.Dictionary
' file for output
Dim fso As New Scripting.FileSystemObject
Dim out_file As Scripting.TextStream
Set out_file = fso.CreateTextFile("C:\emails.csv", True)
' open the inbox
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Dim inbox As MAPIFolder
Set inbox = ns.GetDefaultFolder(olFolderInbox)
' loop through all items (some of which are not emails)
Dim outlook_item As Object
For Each outlook_item In inbox.Items
' only look at emails
If outlook_item.Class = olMail Then
' extract the email address
Dim email_address As String
email_address = GetSmtpAddress(outlook_item, ns)
' add new email addresses to the dictionary and write out
If Not email_list.Exists(email_address) Then
out_file.WriteLine email_address
email_list.Add email_address, ""
End If
End If
Next
out_file.Close
End Sub
' get email address form a Mailoutlook_item
' this entails converting exchange format addresses
' (like " /O=ROOT/OU=ADMIN GROUP/CN=RECIPIENTS/CN=FIRST.LAST")
' to proper email addresses
Function GetSmtpAddress(outlook_item As Outlook.MailItem, ns As Outlook.NameSpace) As String
Dim success As Boolean
success = False
' errors can happen if a user has subsequently been removed from Exchange
On Error GoTo err_handler
Dim email_address As String
email_address = outlook_item.SenderEmailAddress
' if it's an Exchange format address
If UCase(outlook_item.SenderEmailType) = "EX" Then
' create a recipient
Dim recip As Outlook.Recipient
Set recip = ns.CreateRecipient(outlook_item.SenderEmailAddress)
' extract the email address
Dim user As Outlook.ExchangeUser
Set user = recip.AddressEntry.GetExchangeUser()
email_address = user.PrimarySmtpAddress
email_address = user.Name + " <" + user.PrimarySmtpAddress + ">"
success = True
End If
err_handler:
GetSmtpAddress = email_address
End Function
Kudos to http://forums.codeguru.com/showthread.php?441008-Extract-sender-s-email-address-from-an-Exchange-email and Brettdj
In outlook, export a folder to a csv file, then open in Excel. A simple MID function should be able to extract the email address if it's not been placed in a "from" column already.
I need to add bcc recipients to an email loaded from a template. The recipients should be all of the contacts in a certain category. I have the following so far, except it is extremely inefficient and causes Outlook to become unresponsive:
Sub Distribute_Newsletter()
Set newItem = Application.CreateItemFromTemplate("P:\Subscription Templates\subscription template.oft")
newItem.Display
Set oNS = Application.GetNamespace("MAPI")
Set oContacts = oNS.Folders(1).Folders("Contacts")
Dim emailAddress As String
For Each oContactItem In oContacts.Items
If oContactItem.Class = olContact Then
emailAddress = oContactItem.Email1Address
If Not emailAddress = "" Then 'And oContactItem.Categories
Set objRecip = newItem.Recipients.Add(emailAddress)
objRecip.Type = olBCC
End If
End If
Next
Set oNS = Nothing
Set oContacts = Nothing
Set objRecip = Nothing
Set newItem = Nothing
End Sub
What I ended up doing was moving newItem.Display down to just before Set newItem = Nothing. This may not be the most efficient solution, but it gets the job done without causing a crash.