Script the creation of NEW public folders in EX2K3

[Guest]

I'm looking to add many new public folders to an already existing heirarcy of
public folders in exchange 2003. Is there any code that can be run against
the root folder and create new folders within all the subfolders?

example

Root
-----Subfolder1(Already Exists)
+--------------2006(Exists Already)
---------------2007(Needs to be created)
----------------------------------------------Cars(needs to be created)
----------------------------------------------Housing(needs to be created)
----------------------------------------------Air(needs to be created)
----------------------------------------------GT(needs to be created)
-----Subfolder2(Already Exists)
+--------------2006(Exists Already)
---------------2007(Needs to be created)
----------------------------------------------Cars(needs to be created)
----------------------------------------------Housing(needs to be created)
----------------------------------------------Air(needs to be created)
----------------------------------------------GT(needs to be created)


I have to do this a minimum 300 times every year and it keeps getting
bigger...

I have about 90 days before this needs to happen and any help would be
greatly appreciated.

-Jeff

 

[Guest]

Try the macros below; run CreateFolderSetInSubFolders and choose the folder
that corresponds to the Root you illustrated in your example.

Sub CreateFolderSetInSubFolders()
On Error Resume Next

Dim objRootFolder As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder

Set objNS = Application.GetNamespace("MAPI")
'top level folder
Set objRootFolder = objNS.PickFolder

If objRootFolder Is Nothing Then Exit Sub

'create folder sets in subfolders of chosen folder
For Each objFolder In objRootFolder.Folders
CreateFolderSet objFolder
Next

Set objRootFolder = Nothing
Set objFolder = Nothing
Set objNS = Nothing
End Sub

Private Sub CreateFolderSet(objCurrentFolder As Outlook.MAPIFolder)
On Error Resume Next

Dim objFolder As Outlook.MAPIFolder

Set objFolder = objCurrentFolder.Folders("2007")

If objFolder Is Nothing Then
'folder doesn't exist - create
Set objFolder = objCurrentFolder.Folders.Add("2007")
objFolder.Folders.Add "Cars"
objFolder.Folders.Add "Housing"
objFolder.Folders.Add "Air"
objFolder.Folders.Add "GT"
End If

Set objFolder = Nothing
End Sub

 

[Guest]

Phenominal!!! Thank you very much!!!

Try the macros below; run CreateFolderSetInSubFolders and choose the folder
that corresponds to the Root you illustrated in your example.

Sub CreateFolderSetInSubFolders()
On Error Resume Next

Dim objRootFolder As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder

Set objNS = Application.GetNamespace("MAPI")
'top level folder
Set objRootFolder = objNS.PickFolder

If objRootFolder Is Nothing Then Exit Sub

'create folder sets in subfolders of chosen folder
For Each objFolder In objRootFolder.Folders
CreateFolderSet objFolder
Next

Set objRootFolder = Nothing
Set objFolder = Nothing
Set objNS = Nothing
End Sub

Private Sub CreateFolderSet(objCurrentFolder As Outlook.MAPIFolder)
On Error Resume Next

Dim objFolder As Outlook.MAPIFolder

Set objFolder = objCurrentFolder.Folders("2007")

If objFolder Is Nothing Then
'folder doesn't exist - create
Set objFolder = objCurrentFolder.Folders.Add("2007")
objFolder.Folders.Add "Cars"
objFolder.Folders.Add "Housing"
objFolder.Folders.Add "Air"
objFolder.Folders.Add "GT"
End If

Set objFolder = Nothing
End Sub

--
Eric Legault (Outlook MVP, MCDBA, MCTS: Messaging & Collaboration)
Try Picture Attachments Wizard for Outlook:
http://www.collaborativeinnovations.ca
Blog: http://blogs.officezealot.com/legault/