Email Shared folder
Sub ListInboxAndSharedFolders()
Dim outlookApp As Outlook.Application
Dim outlookNamespace As Outlook.Namespace
Dim defaultInbox As Outlook.MAPIFolder
Dim sharedInbox As Outlook.MAPIFolder
Dim folderQueue As Collection
Dim currentFolder As Outlook.MAPIFolder
Dim filePath As String
Dim folderData As String
Dim outputFile As Object
Dim sharedMailboxName As String
' Initialize Outlook and set default inbox
Set outlookApp = New Outlook.Application
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
Set defaultInbox = outlookNamespace.GetDefaultFolder(olFolderInbox)
' Prompt for the shared mailbox name
sharedMailboxName = InputBox("Enter the display name of the shared mailbox:", "Shared Mailbox Name")
' Access the shared inbox
On Error Resume Next
Set sharedInbox = outlookNamespace.Folders(sharedMailboxName).Folders("Inbox")
On Error GoTo 0
If sharedInbox Is Nothing Then
MsgBox "Shared mailbox not found. Please check the name and try again.", vbExclamation
Exit Sub
End If
' Output file path (change to desired location)
filePath = "C:\InboxFoldersList.csv"
' Initialize CSV output
folderData = "Mailbox,Folder Path" & vbNewLine
' Initialize folder queue
Set folderQueue = New Collection
' Add default and shared inboxes to the queue
folderQueue.Add Array("Default Inbox", defaultInbox)
folderQueue.Add Array("Shared Inbox", sharedInbox)
' Loop through all folders in the queue
While folderQueue.Count > 0
Dim folderInfo As Variant
folderInfo = folderQueue(1)
folderQueue.Remove 1
' Get mailbox name and current folder
Dim mailboxName As String
Dim currentFolderPath As String
mailboxName = folderInfo(0)
Set currentFolder = folderInfo(1)
currentFolderPath = currentFolder.FolderPath
' Add current folder to CSV data
folderData = folderData & mailboxName & "," & """" & currentFolderPath & """" & vbNewLine
' Add subfolders to the queue
Dim subFolder As Outlook.MAPIFolder
For Each subFolder In currentFolder.Folders
folderQueue.Add Array(mailboxName, subFolder)
Next
Wend
' Write output to CSV
Set outputFile = CreateObject("Scripting.FileSystemObject").CreateTextFile(filePath, True)
outputFile.Write folderData
outputFile.Close
' Clean up
Set outputFile = Nothing
Set outlookApp = Nothing
Set outlookNamespace = Nothing
Set defaultInbox = Nothing
Set sharedInbox = Nothing
Set folderQueue = Nothing
MsgBox "Folder list saved to: " & filePath, vbInformation
End Sub