Query Outlook Global Address List From Access VBA - vba

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

Related

Is there any way to get the Distribution Group name of a NewEmail Event in Outlook VBA?

I'm trying to divert new emails in Outlook from a distribution group called Customer Service to a subfolder during a certain time. I don't think rules have the capability to divert emails at a certain time so I'm using Application.NewEmail Event.
I have my code set up right now so that it could divert emails from an Exchange sender's email address to a subfolder. However, I need to somehow be able to do the same thing with a Distribution Group and I'm not sure how to extract the information necessary to identify a distribution group.
Here's my code:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal cusItem As Object)
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
Dim strAddress As String, strEntryId As String
Dim objAddressentry As Outlook.AddressEntry, objExchangeUser As Outlook.ExchangeUser
Dim objReply As Outlook.MailItem, objRecipient As Outlook.Recipient
Dim objDestFolder As Outlook.MAPIFolder
If TypeName(cusItem) = "MailItem" And cusItem.SenderEmailType = "EX" Then
On Error GoTo ErrorHandler
Set objReply = cusItem.Reply()
Set objRecipient = objReply.Recipients.Item(1)
strEntryId = objRecipient.EntryID
objReply.Close OlInspectorClose.olDiscard
Set objAddressentry = objNS.GetAddressEntryFromID(strEntryId)
Set objExchangeUser = objAddressentry.GetExchangeUser()
strAddress = objExchangeUser.PrimarySmtpAddress()
If strAddress = "jabach#example.com" And TimeValue(Now()) >= TimeValue("08:00:00 AM") And TimeValue(Now()) <= TimeValue("05:00:00 PM") Then
Set objDestFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("ryule")
cusItem.Move objDestFolder
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & vbCrLf & "Click Ok to continue"
Resume ProgramExit
End Sub
There's also some issues with Application_Startup() not actually firing up Outlook which is why I have all those variables declared twice.
You need to check out the AddressEntry.AddressEntryUserType property which returns a constant from the OlAddressEntryUserType enumeration representing the user type of the AddressEntry. AddressEntryUserType provides a level of granularity for user types that is finer than that of AddressEntry.DisplayType. The DisplayType property does not distinguish users with different types of AddressEntry, such as an AddressEntry that has a Simple Mail Transfer Protocol (SMTP) email address, a Lightweight Directory Access Protocol (LDAP) address, an Exchange user address, or an AddressEntry in the Outlook Contacts Address Book. All these entires have olUser as their AddressEntry.DisplayType. For example:
Sub DemoAE()
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
If oAE.AddressEntryUserType = _
olExchangeUserAddressEntry Then
Set oExUser = oAE.GetExchangeUser
Debug.Print(oExUser.JobTitle)
Debug.Print(oExUser.OfficeLocation)
Debug.Print(oExUser.BusinessTelephoneNumber)
End If
Next
End If
Next
End Sub
So, you may need to use the AddressEntry.GetExchangeDistributionList method in case of Exchange distribution lists.
The OlAddressEntryUserType enumeration provides the following constants:
olExchangeAgentAddressEntry - An address entry that is an Exchange agent.
olExchangeDistributionListAddressEntry - An address entry that is an Exchange distribution list.
olExchangeOrganizationAddressEntry - An address entry that is an Exchange organization.
olExchangePublicFolderAddressEntry - An address entry that is an Exchange public folder.
olExchangeRemoteUserAddressEntry - An Exchange user that belongs to a different Exchange forest.
olExchangeUserAddressEntry - An Exchange user that belongs to the same Exchange forest.
olLdapAddressEntry - An address entry that uses the Lightweight Directory Access Protocol (LDAP).
olOtherAddressEntry - A custom or some other type of address entry such as FAX.
olOutlookContactAddressEntry - An address entry in an Outlook Contacts folder.
olOutlookDistributionListAddressEntry - An address entry that is an Outlook distribution list.
olSmtpAddressEntry - An address entry that uses the Simple Mail Transfer Protocol (SMTP).
Finally, I'd suggest handling the NewMailEx event of the Application class. The NewMailEx event fires when a new message arrives in the Inbox and before client rule processing occurs. You can use the Entry ID returned in the EntryIDCollection array to call the NameSpace.GetItemFromID method and process the item.

Searching Outlook email (and replying to it) using Excel VBA

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

search for emails with specific subject title IF UNREAD and save attachments into folder

I am using the following vba code which should search for all emails with a specific subject title i.e. with the subject 'test'
Then only if the email is unread then save the attachment from that email into a folder.
There may be one or several emails with the subject test so I want all the unread emails with the subject test to have their attachments saved to the folder.
Here is my code:
Sub Work_with_Outlook()
Set olApp = CreateObject("Outlook.Application")
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim myItem As Object
Dim myAttachment As Outlook.Attachment
Dim I As Long
Dim olMail As Variant
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
Set UnRead = myTasks.Restrict("[UnRead] = False")
Set olMail = myTasks.Find("[Subject] = ""test""")
If Not (olMail Is Nothing) And UnRead.Count = 0 Then
For Each myItem In myTasks
If myItem.Attachments.Count <> 0 Then
For Each myAttachment In myItem.Attachments
If InStr(myAttachment.DisplayName, ".txt") Then
I = I + 1
myAttachment.SaveAsFile "\\uksh000-file06\Purchasing\NS\Unactioned\" & myAttachment
End If
Next
End If
Next
For Each myItem In myTasks
myItem.UnRead = False
Next
MsgBox "Scan Complete."
Else
MsgBox "There Are No New Supplier Requests."
End If
End Sub
This does work to some degree, if I only have one email with the subject 'test' and it is unread then the script will get the attachment from that email and save it to my folder. However, if I have one email with the subject 'test' which is read and another email with the subject 'test' which is unread then the code won't work?
Please can someone show me where I am going wrong? Thanks in advance
It looks like you need to combine both comditions into a single one and use the Find/FindNext or Restrict methods to get an instance of the Items class which contains all items correspodning to your conditons. For example:
Set resultItems = myTasks.Restrict("[UnRead] = False AND [Subject] = ""test""")
See Enumerating, Searching, and Filtering Items in a Folder for information in MSDN.
Also you may find the sample code in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
How To: Get unread Outlook e-mail items from the Inbox folder
Advanced search in Outlook programmatically: C#, VB.NET

Outlook 2010 VBA code to show alias of recipient

My company assigns each employee an ID which is stored as their 'alias' in Outlook. We use this ID often, and I am looking for an easy way to see it.
Right now I enter the recipient name in a new email, double click the name, click on more options, then Outlook properties. I am looking for a macro that where I would enter the recipient name in a new email, and then run the macro which would just pop up the recipient's alias as a message box (ideally copy it to the clipboard). I have tried (and failed) to write this on my own.
The code I have so far is below. However, this code gives /o=corpexchange/ou=exchange administrative group.....
I am trying to get it to return the alias
Sub ReadRecpDetail2()
Dim myOlApp As Outlook.Application
Dim myItem As Outlook.MailItem
Dim myRecipient As Outlook.recipient
Dim recipient As Outlook.recipient
Set myOlApp = GetObject(, "Outlook.Application")
Set myItem = myOlApp.ActiveInspector.CurrentItem
For Each recipient In myItem.Recipients
recipient.Resolve
MsgBox recipient.AddressEntry
Next recipient
End Sub
To Recreate:
Open new outlook email
Enter email address and resolve
Run macro
Try to use the following methods:
Use the CreateRecipient method of the Namespace class to create a Recipient object.
Call the Resolve method of the Recipient class to resolve a Recipient object against the Address Book.
Get the AddressEntry property value, returns the AddressEntry object corresponding to the resolved recipient.
Call the GetExchangeUser method of the AddressEntry class, it returns an ExchangeUser object that represents the AddressEntry if the AddressEntry belongs to an Exchange AddressList object such as the Global Address List (GAL) and corresponds to an Exchange user.
The Alias property of the ExchangeUser class returns a String representing the alias for the ExchangeUser.
You may also find the Getting Started with VBA in Outlook 2010 article helpful.
With all your help I was able to solve this by capturing recipient address entry, adding it as a new item, showing alias, then deleting the recipient:
Sub ReadRecpDetail()
Dim myOlApp As Outlook.Application
Dim myItem As Outlook.mailItem
Dim myRecipient As Outlook.recipient
Dim recipient As Outlook.recipient
Dim SMTPaddress As String
Dim entry As Outlook.AddressEntry
Dim entrystring As String
Dim Copytoclipboard As New DataObject
Set myOlApp = GetObject(, "Outlook.Application")
Set myItem = myOlApp.ActiveInspector.CurrentItem
Set recipient = myItem.Recipients.Item(1)
Set myRecipient = myItem.Recipients.Add(recipient.AddressEntry)
myRecipient.Resolve
entrystring = myRecipient.AddressEntry.GetExchangeUser.Alias
MsgBox (entrystring)
Copytoclipboard.SetText entrystring
Copytoclipboard.PutInClipboard
myRecipient.Delete
End Sub
I had a similar situation where I needed to print out all the user names of the recipients in an email so I could export them to another application. I based my solution off of your answer which is below in case it helps anyone else.
Sub PrintRecipientAliases()
Dim myOlApp As Outlook.Application
Dim myItem As Outlook.MailItem
Dim recipient As Outlook.recipient
Set myOlApp = GetObject(, "Outlook.Application")
Set myItem = myOlApp.ActiveInspector.CurrentItem
For Each recipient In myItem.Recipients
With recipient
Debug.Print recipient.AddressEntry.GetExchangeUser.Alias
End With
Next
End Sub

How to access the Flag completed date?

I move my emails by selecting "Follow up - Mark completed Option", to another folder.
Now I want to write a program to check hom many emails did I complete today by comparing the Flag completed date with todays date.
But I am not able to find how to access the Flag completed date.
Can you please help.
Thanks,
Alok
The property is Outlook.MailItem.TaskCompletedDate. Try something like:
Sub GetCompletedToday()
Dim olNameSpace As Outlook.NameSpace
Dim olFolder As Outlook.Folder
Dim olMailItem As Outlook.MailItem
Dim CompletedTodayCount As Long
Set olNameSpace = Application.GetNamespace("MAPI")
Set olFolder = olNameSpace.Folders(1).Folders("tester")
For Each olMailItem In olFolder.Items
If olMailItem.TaskCompletedDate = Date Then
CompletedTodayCount = CompletedTodayCount + 1
End If
Next olMailItem
Debug.Print CompletedTodayCount
End Sub
You can access the flags by using the expression.FlagStatus
See this link
Topic: FlagStatus Property
Link: http://msdn.microsoft.com/en-us/library/aa212013%28v=office.11%29.aspx
For example, this will give you the status of all selected emails
OUTLOOK VBA CODE
Option Explicit
Sub Sample()
Dim Messages As Selection
Dim Msg As MailItem
Dim NamSpace As NameSpace
Set NamSpace = Application.GetNamespace("MAPI")
Set Messages = ActiveExplorer.Selection
If Messages.Count = 0 Then Exit Sub
For Each Msg In Messages
Debug.Print Msg.FlagStatus
Next
End Sub
For message(s) with No flags it will give you a 0
for Mark Completed it will give you 1 and
for Other flags it will give you 2
So you can actually use an If statement to check for the .FlagStatus property and the Mail Date to achieve what you want.
HTH