I'm using the below code I've found to create email folders in Outlook from a list in Excel. I can get it working fine from my default email account but I'm struggling to implement it for a shared mailbox.
I've added code to return the account number (as xref) associated with a specified email address. How can I amend the 'Add folders' section to utilise this information (and will I need code to 'reset' the account back to the user's default?).
I will then also need to know how to move an existing folder to another folder (e.g. from 'DEV TEST' to 'DEV TEST/ARCHIVE').
Thanks.
Sub CreateEmailFol()
Dim admin As Worksheet
Set admin = ThisWorkbook.Worksheets("Admin")
Const olFolderInbox As Long = 6
Dim OutlApp As Object
Dim a(), x
Dim IsCreated As Boolean
Dim OutApp As Outlook.Application
Dim i As Long
' Get account number for email address
Set OutApp = CreateObject("Outlook.Application")
For i = 1 To OutApp.Session.Accounts.Count
If OutApp.Session.Accounts.Item(i) = "x@x.com" Then xref = i
Next i
' Copy folder names into array to speed up the code
With admin
If .FilterMode Then .ShowAllData
a = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Offset(1, 0).Value
If Not IsArray(a) Then x = a: ReDim a(1 To 1): a(1) = x
End With
' Use already open Outlook application if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
' Add folders
With OutlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("DEV TEST")
For Each x In a
.Folders.Add x
Next
End With
' Release the memory of object variable
Set OutlApp = Nothing
Set OutApp = Nothing
End Sub