I am trying to use Excel VBA to find the subject line of all email in a shared Outlook folder, including a subfolder several levels deep (there are hundreds of folders at different levels).
I found how to access subfolders but not how to find the subfolders and loop through all emails in each folder. From reading online this is most likely not possible.
My solution is to produce another list with all subfolder paths and then adapt the main code to loop through all paths.
Is there a way to find all subfolder paths via Excel VBA or directly in Outlook?
This is the main code for a specific subfolder (in this case two levels deep, "myFolder" in the shared folder "myname@mydomain.com) that I will be able to adapt to different subfolders of different "depths" if I have the list.
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Outlook.Namespace
Dim olShareName As Outlook.Recipient
Dim Folder As MAPIFolder
Dim olItems As Outlook.Items
Dim OutlookMail As Variant
Dim arrResults() As Variant
Dim ItemCount As Long
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set olShareName = OutlookNamespace.CreateRecipient("myname@mydomain.com")
Set Folder=OutlookNamespace.GetSharedDefaultFolder(olShareName,olFolderInbox).Folders("myFolder")
Set olItems = Folder.Items
If olItems.Count > 0 Then
ReDim arrResults(1 To olItems.Count, 1 To 5)
ItemCount = 0
For Each OutlookMail In olItems
ItemCount = ItemCount + 1
arrResults(ItemCount, 1) = OutlookMail.Subject
arrResults(ItemCount, 2) = OutlookMail.ReceivedTime
arrResults(ItemCount, 3) = OutlookMail.SenderName
arrResults(ItemCount, 4) = OutlookMail.Size
arrResults(ItemCount, 5) = OutlookMail.Categories
Next OutlookMail
Worksheets(1).Range("A5").Resize(UBound(arrResults, 1), 5) = arrResults
Else
MsgBox "No items found!", vbExclamation
End If
End Sub