Outlook Shared Contacts copied to MyContacts - excel

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

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.

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/Outlook VBA - select folders in different Mailboxes

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).

How to access an Outlook folder from an Excel macro

I have VBA code in Excel to select the main Outlook inbox. I would like to select any folder or subfolder in that inbox.
For example, I would like to select the subfolder ALD in this screenshot of my main inbox:
I have another email address in Outlook with folders and subfolders. I would like to select any folder or subfolder of this other email address. For example, I have another email address called xxxx#yyyy.com and a folder aaaa and inside a subfolder bbbb. How would I select the subfolder bbbb?
Sub OpenOutlookFolder()
Dim xOutlookApp As Outlook.Application
Dim xNameSpace As Outlook.Namespace
Dim xFolder As Outlook.Folder
Dim xFolderType As OlDefaultFolders
On Error Resume Next
Set xOutlookApp = New Outlook.Application
Set xNameSpace = xOutlookApp.Session
Set xFolder = xNameSpace.GetDefaultFolder(olFolderInbox
xFolder.Display
Set xFolder = Nothing
Set xNameSpace = Nothing
Set xOutlookApp = Nothing
Exit Sub
End Sub
Something along the lines of:
Dim ThisNamespace As Outlook.NameSpace: Set ThisNamespace = Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder: Set Inbox = ThisNamespace.GetDefaultFolder(olFolderInbox)
Dim BaseFolder As Outlook.MAPIFolder: Set BaseFolder = Inbox '.Folders("SubFolder1\SubFolder2...")
For direct subfolder access, uncomment within the last line and update the path
If you want to create a folder structure which is searchable/editable then my answer in this question may be of interest: How can one iterate through the subfolders of a subfolder of a shared mail inbox folder?
Finally by checking again the link Get reference to additional Inbox, I managed to modify my macro in order it works and does as I want. Please find the code below:
Sub OpenOutlookFolderworks()
Dim xOutlookApp As Outlook.Application
Dim xNameSpace As Outlook.Namespace
Dim xFolder As Outlook.Folder
Dim vRecipient As Outlook.MAPIFolder
Dim xFolderType As OlDefaultFolders
On Error Resume Next
Set xOutlookApp = New Outlook.Application
Set xNameSpace = xOutlookApp.Session
Set xFolder = xNameSpace.GetDefaultFolder(olFolderInbox)
Set xFolder = xFolder.Folders("payment office")
Set xFolder = xFolder.Folders("JIRA")
xFolder.display
Set xFolder = Nothing
Set xNameSpace = Nothing
Exit Sub
End Sub

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