Excel/Outlook VBA - select folders in different Mailboxes - excel

I'd like to collect some email count data from Outlook using Excel VBA. In addition to my personal email, I also have access to other mailboxes account/stores(?). The label on the Outlook mailbox/accounts are HR,Marketing, Accounting. I'd like to loop through the folders in these mailboxes/stores and perform some task.
When I write a for loop through Sessions.Accounts, it only accesses my default mailbox (i.e. not HR,Marketing,Accounting). It looks like I can access my non-default mailboxes if I loop through Session.Stores:
Sub test()
Dim olApp As Outlook.Application
Set olApp = Outlook.Application
For Each acct In olApp.Session.Stores
MsgBox acct
'how can I access folders and emails within these Stores?
End Sub
This returns message boxes with HR, Marketing, Accounting. I am not able to select the inbox or other folders within these non-default mailboxes though.
For my default mailbox, I was able to get it:
Sub default_email_count()
Dim olApp As Outlook.Application
Dim objNS As Outlook.Namespace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = olbNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("sample_folder")
Count = olFolder.Items.Count
Msgbox Count
'this code successfully outputs the count of emails in my default mailbox within the folder "sample folder"
How can I extend the above code to work across other Stores and not just my default mailbox?
Thanks in advance.

The following code shows how to enumerate all folders on all stores for an Outlook session.
The code sample begins by getting all the stores for the current session using the NameSpace.Stores property of the current session, Application.Session.
For each store of this session, it uses Store.GetRootFolder to obtain the folder at the root of the store.
For the root folder of each store, it iteratively calls the EnumerateFolders procedure until it has visited and displayed the name of each folder in that tree.
Sub EnumerateFoldersInStores()
Dim colStores As Outlook.Stores
Dim oStore As Outlook.Store
Dim oRoot As Outlook.Folder
On Error Resume Next
Set colStores = Application.Session.Stores
For Each oStore In colStores
Set oRoot = oStore.GetRootFolder
Debug.Print (oRoot.FolderPath)
EnumerateFolders oRoot
Next
End Sub
Private Sub EnumerateFolders(ByVal oFolder As Outlook.Folder)
Dim folders As Outlook.folders
Dim Folder As Outlook.Folder
Dim foldercount As Integer
On Error Resume Next
Set folders = oFolder.folders
foldercount = folders.Count
'Check if there are any folders below oFolder
If foldercount Then
For Each Folder In folders
Debug.Print (Folder.FolderPath)
EnumerateFolders Folder
Next
End If
End Sub

If the mailboxes are already in your profile, use the Namespace.Stores collection. Default folders can be accessed using Store.GetDefaultFolder (instead of Namespace.GetDefaultFolder).
You can also use Namespace.GetSharedDefaultFolder - it takes Recipient object as one of its parameters (you can get it from Namespace.CreateRecipient).

Related

Pulling e-mail addresses into excel with VBA from outlook

At work I have two e-mail accounts in outlook. One is an individual e-mail and the other is a general department e-mail.
How would I use VBA to get excel to access the general e-mail and pull the sender of each e-mail into a string? I need to iterate over each e-mail in the inbox ignoring e-mails in any sub folders.
Here's the code I've written so far. Hopefully I'm at least on the right track.
Public Sub test()
Dim emailApp As Outlook.Application, emailNamespace As Outlook.Namespace
Dim oFolder As MAPIFolder, oMail As Outlook.MailItem
Dim iSelect As Outlook.AccountSelector, iBox As Outlook.Account
Dim tEmailAddress As String
Set emailApp = New Outlook.Application
Set emailNamespace = OutlookApp.GetNamespace("MAPI")
Set oFolder = emailNamespace.GetDefaultFolder(olFolderInbox)
'I think im on the right track here.......
Set iBox = iSelect.SelectedAccount
For Each oMail In oFolder.Items
tEmailAddress = oMail.SenderEmailAddress
'Do other stuff for the project.........
Next
End Sub
EDIT: Posting a completed code sample for the next person who is having this problem.
Public Sub test()
Dim emailApplication As Outlook.Application, emailAccounts As Outlook.Accounts
Dim emailAccount As Outlook.Account, tAccount As Outlook.Account
Dim emailStore As Outlook.Store, emailInbox As Outlook.Folder, tMail As Variant
Set emailApplication = New Outlook.Application
Set emailAccounts = emailApplication.Session.Accounts
For Each tAccount In emailAccounts
If tAccount.DisplayName = "UserEmail#DemoEmail.com" Then: Set emailAccount = tAccount
Next
Set emailStore = emailAccount.DeliveryStore
Set emailInbox = emailStore.GetDefaultFolder(olFolderInbox)
On Error Resume Next
For Each tMail In emailInbox.Items
Debug.Print tMail.SenderEmailAddress
Next
Err.Clear
End Sub
The following code is not required:
'I think im on the right track here.......
Set iBox = iSelect.SelectedAccount
Instead, you may just rely on the GetDefaultFolder method which allows retrieving default folders (from the delivery store):
Set oFolder = emailNamespace.GetDefaultFolder(olFolderInbox)
If you need to choose a specific store in the profile you may find the required account by using the Namespace.Accounts property which returns an Accounts collection object that represents all the Account objects in the current profile. The Account.DeliveryStore property returns a Store object that represents the default delivery store for the account. The Store.GetDefaultFolder method returns a Folder object that represents the default folder in the store and that is of the type specified by the FolderType argument. This method is similar to the GetDefaultFolder method of the NameSpace object. The difference is that this method gets the default folder on the delivery store that is associated with the account, whereas NameSpace.GetDefaultFolder returns the default folder on the default store for the current profile.
I need to iterate over each e-mail in the inbox ignoring e-mails in any sub folders.
The current folder is processed only when you deal with Folder.Items collection.

VBA Outlook Email Attachment Save Permissions

This script is suppose to loop through my outlook folder inbox-> Work Request
Then for each mail item in that folder download each attachment and save if to a file location.
Code seems to work fine in finding the folder and the correct emails however it is giving me an error message on the following line of code saying "Run-Time Error '-2147024891(80070005) Cannot save the attachment. You don't have the appropriate permissions to perform this operation."
I have tried multiple save location including our external cloud drive and my personal desktop. Currently the code is saving to my desktop and still says I do not have appropriate permissions to save. Any help would be greatly appreciated.
olAtt.SaveAsFile ("C:\Users\John Smith\Desktop\WOR Email Download")
The rest of the script is depicted below.
Option Explicit
Sub Download_Outlook_Attachemtns()
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olItem As Object
Dim MailItem As Outlook.MailItem
Dim olAtt As Outlook.Attachment
Dim FileLocation As String
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
'single folder link to hidden sheet folders([admin].[Mailbox].text)
Set olFolder = olNS.Folders("JohnSmith#work.com")
Set olFolder = olFolder.Folders("Inbox")
Set olFolder = olFolder.Folders("Work Requests")
For Each olItem In olFolder.Items
If olItem.Class = olMail Then
Set MailItem = olItem
'Debug.Print MailItem.Subject
For Each olAtt In MailItem.Attachments
If MailItem.ReceivedTime > ThisWorkbook.Worksheets("Email_Info").Range("C6").Value Then
olAtt.SaveAsFile ("C:\Users\John Smith\Desktop\WOR Email Download")
'olAtt.SaveAs Filename:=Application.GetSaveAsFilename
End If
Next olAtt
End If
Next olItem
'Set olFolder = Nothing
'Set olNS = Nothing
End Sub
First of all, instead of iterating over all items in the folder:
For Each olItem In olFolder.Items
If olItem.Class = olMail Then
Set MailItem = olItem
You can find all items with attachments in the folder and iterate over them only. The Find/FindNext or Restrict methods of the Items class do the magic. Read more about these methods in the articles I wrote for the technical blog:
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
For example, you can use the following search criteria (VBA syntax):
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:hasattachment" & Chr(34) & "=1"
Also it makes sense to optimize the code by changing the order of conditions:
For Each olAtt In MailItem.Attachments
If MailItem.ReceivedTime > ThisWorkbook.Worksheets("Email_Info").Range("C6").Value Then
Instead of checking the received time of the email for each attachment you can check it once for the email before iterating over attached files or, better yet, you may include another condition to the search criteria by using the logical AND operator in the search string.
Finally, you may try to check the Attachment.Type property value before trying to save anything to the disk. The property returns an OlAttachmentType constant indicating the type of the specified object.
You must include the file name besides the folder name. Currently, you are telling Outlook to save to a file conflicting with an existing folder name ("WOR Email Download"), hence the "no access" error - the file cannot be created since its name conflicts with an existing folder name. Change your code to
if olAtt.Type = olByValue Then
olAtt.SaveAsFile "C:\Users\John Smith\Desktop\WOR Email Download\" & olAtt.FileName
End If

Outlook Shared Contacts copied to MyContacts

I am trying to copy Outlook Shared Contacts into a folder under MyContacts. I am looking for an easy solution for my team outside of using an Import Wizard or physically copy/paste due to the computer challenged. I have been successful in doing this from MyContacts/Contacts to MyContacts/Another_Folder but can't seem to copy from a Shared Contact folder.
I am running a macro from Excel so that all users can just run the Excel macro and it will modify their Outlook instead of having everyone Allow macros in Outlook.
Current running code is here:
Sub CopyContacts()
Dim ContactItem As Outlook.ContactItem
Dim Name As Outlook.Namespace
Dim Folder As Outlook.Folder
Dim Item As Object
Set Name = Outlook.GetNamespace("MAPI")
Set Folder = Name.GetDefaultFolder(olFolderContacts)
For Each Item In Folder.Items
If Item.Class = olContact Then
Set ContactItem = Item.Copy
ContactItem.Move Folder.Folders("Another_Folder")
End If
Next
End Sub
I would like to run an Excel Macro to copy all the contents from Shared Contacts John Doe's folder to Another_Folder.
I would be great if the Macro deleted all the contents from Another_Folder before the copy function.
You can use the NameSpace.GetSharedDefaultFolder method which returns a Folder object that represents the specified default folder for the specified user. This method is used in a delegation scenario, where one user has delegated access to another user for one or more of their default folders (for example, their shared Calendar folder).
Sub ResolveName()
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.Folder
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("John Doe")
myRecipient.Resolve
If myRecipient.Resolved Then
Call ShowContacts(myNamespace, myRecipient)
End If
End Sub
Sub ShowContacts(myNamespace, myRecipient)
Dim ContactsFolder As Outlook.Folder
Set ContactsFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderContacts)
ContactsFolder.Display
End Sub

Connection to subfolder of the inbox of a shared mailbox

On my laptop it works, however for the team the code works only sometimes. They get below error message.
It is supposed to connect to a specific Outlook folder.
When I reduce code to
Set Folder = Ns.GetSharedDefaultFolder(olShareName, olFolderInbox) '// works fine
then there is no issue on their side, however when variable is extended to specific folder it works 1 out of 10 times.
References are set in Excel, folders names are correct because it works on my laptop.
in line
`
Sub macro()
'declare variable
Dim olApp As Outlook.Application
Dim Ns As Outlook.Namespace
Dim Folder As Outlook.MAPIFolder
Dim olShareName As Outlook.Recipient
Dim olMailItem As Outlook.MailItem
'clear objects
Set olApp = Nothing
Set Ns = Nothing
Set olShareName = Nothing
'set outlook variable
Set olApp = New Outlook.Application
Set Ns = olApp.GetNamespace("MAPI")
Set olShareName = Ns.CreateRecipient("xxx#xx.com") /// Owner's email address
Set Folder = Ns.GetSharedDefaultFolder(olShareName, olFolderInbox).Folders("SHAREPOINT COO").Folders("COO") '// doesn't work
'Set Folder = Ns.GetSharedDefaultFolder(olShareName, olFolderInbox) '// works fine
Set Items = Folder.Items
end sub
The error means the folder does not exist. Keep in mind that Namespace.Folders returns the top level folders of all stores in the profile. Unless you have a mailbox (not a folder) named "Inbox", that line will fail.
If you want the Inbox folder, use Namespace.GetDEfaultFolder(olFolderInbox) instead.
Use the Recipient.Resolve method which attempts to resolve a Recipient object against the Address Book before calling the NameSpace.GetSharedDefaultFolder method.
Set olShareName = Ns.CreateRecipient("xxx#xx.com") /// Owner's email address
olShareName.Resolve
Set Folder = Ns.GetSharedDefaultFolder(olShareName, olFolderInbox)
Also I'd recommend breaking the chain of property or method calls by declaring each property or method call on a separate line of code. Thus, you will be able to find out which property or method fails.

Excel vba: Looping through all subfolders in Outlook email to find an email with certain subject

I have written the following code in Excel VBA that opens an email with the given subject if located in the default inbox folder in Outlook.
However, I would like to search for this email in all inbox subfolders.
Because the code will be used by several users, I do not know the number and the name of their outlook inbox subfolders. Any ideas on how I could search this email in all subfolders?
Sub GetEmail()
Dim OutApp as Object
Dim Namespace as Object
Dim Folder as Object
Dim myMail as Object
Set OutApp = CreateObject("Outlook.Application")
Set Namespace = OutApp.GetNamespace ("MAPI")
Set Folder = Namespace.GetDefaultFolder(6)
Set myMail = Folder.Items.Find ("[Subject] = ""Test""")
myMail.Display
End Sub
The below code cycles through all folders in Outlook, to the level one beneath the Inbox. You can just look at the inbox by specifying the initial folder to look at. Thus you can search the folder as you loop through. you can add further sub folders by looping deeper, or by saying folders.count > X.
I have always found Outlook from Excel frustrating so have made this Early Bound to make coding easier. This means that you will need to go to Tool/References and add Microsoft Outlook 16(x).0 Object Library
You can change it back to late bound after coding, as early binding will give you IntelliSense and make life a whole lot easier.
Sub GetEmail()
Dim OutApp As Outlook.Application
Dim Namespace As Outlook.Namespace
Dim Mfolder As Outlook.MAPIFolder
Dim myMail As Outlook.Items
Dim Folder As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim UserFolder As Outlook.MAPIFolder
Set OutApp = New Outlook.Application
Set Namespace = OutApp.GetNamespace("MAPI")
On Error Resume Next
For Each Folder In Namespace.Folders
For Each SubFolder In Folder.Folders
For Each UserFolder In SubFolder.Folders
Debug.Print Folder.Name, "|", SubFolder.Name, "|", UserFolder.Name
Next UserFolder
Next SubFolder
Next Folder
On Error GoTo 0
End Sub
The on error is to skip any issues with outlook mapping Archive pst files.

Resources