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.
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'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
I am writing some Access VBA code to get a count of how many times a specific email address has been emailed. The issue that I am running into is that the first time the email is sent out, the email leaves our Exchange sever as
email1#domain.com
But once the person replies to that email, then all subsequent messages are displayed as
'lastname, firstname'
I use the below VBA code to search for the email1#domain.com example, but how can I use access vba to get the name from the global address list?
Function Test()
Dim searchEmail As String: searchEmail = "'abc123#abc123.com'"
Dim olApp As Outlook.Application
Dim olNs As NameSpace
Dim Fldr As MAPIFolder
Dim olReply As Outlook.MailItem
Dim msg As Object
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderSentMail)
For Each msg In Fldr.Items
If TypeName(msg) = "MailItem" Then
If msg.To = searchEmail Then
'now we start counting
End If
End If
Next msg
End Function
Similar to the answer I posted here, instead of checking the To property of the MailItem object (which, per the linked documentation, contains the display names only), query the contents of the Recipients collection and, for each Recipient object, test the value held by the Address property against your searchEmail variable.
The Address property will consistently contain the email address of the recipient, never a display name.
That is, instead of:
For Each msg In Fldr.Items
If TypeName(msg) = "MailItem" Then
If msg.To = searchEmail Then
'now we start counting
End If
End If
Next msg
You might use something like:
For Each msg In Fldr.Items
If TypeName(msg) = "MailItem" Then
For Each rcp In msg.Recipients
If rcp.Address = searchEmail Then
'now we start counting
End If
Next rcp
End If
Next msg
I want to search ALL my outlook for latest message in a conversation (I use Subject name as search key).
This latest message can be in Inbox, Sent Items, in a sub folder of Inbox, a sub-sub folder of Inbox (anywhere).
I can achieve this by some very tedious code, going through every level of each major folder, but not only this method is very messy, I can't determine if this found message is the latest in this conversation.
I have the following code, which
--> Searches Inbox for "searchKey"
--> If finds it in Inbox folder, replies to it
--> If not, it moves into subfolders of Inbox, and continues the same process
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olFldr As MAPIFolder
Dim olMail ' As Outlook.MailItem
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set olFldr = Fldr
tryAgain:
For Each olMail In olFldr.Items
If InStr(olMail.Subject, searchKey) <> 0 Then
Set ReplyAll = olMail.ReplyAll
With ReplyAll
.HTMLBody = Msg & .HTMLBody
emailReady = True
.Display
End With
End If
Next olMail
If Not emailReady Then
i = i + 1
If i > Fldr.Folders.Count Then
MsgBox ("The email with the given subject line was not found!")
Exit Sub
Else
Set olFldr = Fldr.Folders(i)
GoTo tryAgain
End If
End If
This code might be confusing and long, so please let me know if you need any clarification.
The question is: How can I search through ALL Outlook, without going manually through every folder/subfolder/sub-subfolder... without this method, and find the LAST message in a specific conversation? Or, at least, how can I optimize this code so I don't miss any folder, and know the dates and times these emails were sent?
You can use the built in AdvancedSearch function, which returns a Search object containing items.
These should have date properties, so you only need your code to go through the search object mailItems and find that with the latest date ( ReceivedTime)?
I would suggest using the bottom example on that page - it gets a table object from the search, and then you use
Set MyTable = MySearch.GetTable
Do Until MyTable.EndOfTable
Set nextRow = MyTable.GetNextRow()
Debug.Print nextRow("ReceivedTime")
Loop
From there, you can do the comparison to find the latest time, and if you want to do something with the mailitem you would need to obtain the "EntryID" column from the table.
Then use the GetItemFromID method of the NameSpace object to obtain a full item, since the table returns readonly objects.
You can also apply a date filter to the search if you wish, if you knew a minimum date for instance.
To go through all folders do this:
Go once through all the primary folders in Outlook and then for each major folder go through each subfolder. If you have more branches then is guess you have to add more levels to the code "for each Folder3 in folder2.folders". Also in the if clause you can test the date of the mail and go from the newest to the oldest. Set oMsg.display to see what mail is being checked
Public Sub FORWARD_Mail_STAT_IN()
Dim Session As Outlook.NameSpace
Dim oOutLookObject As New Outlook.Application
Dim olNameSpace As NameSpace
Dim oItem As Object
Dim oMsg As Object
Dim searchkey As String
Set oOutLookObject = CreateObject("Outlook.Application")
Set oItem = oOutLookObject.CreateItem(0)
Set olNameSpace = oOutLookObject.GetNamespace("MAPI")
Set Session = Application.Session
Set Folders = Session.Folders
For Each Folder In Folders 'main folders in Outlook
xxx = Folder.Name
For Each Folder2 In Folder.Folders 'all the subfolders from a main folder
yyy = Folder2.Name
Set oFolder = olNameSpace.Folders(xxx).Folders(yyy) 'in each folder we search all the emails
For Z = oFolder.Items.Count To 1 Step -1 ' For Z = 1 To oFolder.Items.Count
With oFolder.Items(Z)
Set oMsg = oFolder.Items(Z)
If Format(oMsg.SentOn, "mm/dd/yyyy") = Format(Date, "mm/dd/yyyy") And InStr(1, LCase(oMsg.Subject), searchkey, vbTextCompare) > 0 Then
oMsg.display
' insert code
End If
End With
Next Z
Next Folder2
Next Folder
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.