Create mutiple folders in OUtlook from a txt file

[Icek]

Hi All,

I would like to create a 330 folders and subfolders in a Outlook account (not the main one) from a text file.
The text file is like that:
Folder1
Folder1/Sub1
Folder1/Sub1/Sub2
Folder2/Sub1
Folder2/Sub2
etc....

Thus I have created this code, but there is an issue when I want to create a reccursive path:

Sub AddFolders()

Dim myNameSpace As Outlook.NameSpace
Dim rootFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder
Dim strComputer As String
Dim arrFolders() As String
Dim I As Long

Set myNameSpace = Application.GetNamespace("MAPI")

Set fso = CreateObject("Scripting.FileSystemObject")
Set objInputFile = fso.OpenTextFile("C:\temp\test.txt", 1, True)

Do Until objInputFile.AtEndOfLine
strComputer = objInputFile.ReadLine
arrFolders() = Split(strComputer, "\")

Set rootFolder = myNameSpace.Folders("Root")

For I = 0 To UBound(arrFolders)
On Error Resume Next
Set myNewFolder = rootFolder.Folders.Add(arrFolders(I))
'Set rootFolder = rootFolder.Item(arrFolders(I)) --> THAT IS THE LINE THAT CAUSES THE ISSUE
Next

Erase arrFolders

Loop
objInputFile.Close
Set rootFolder = Nothing
Set myNewFolder = Nothing
Set myNameSpace = Nothing

End Sub

May be someone has an idea to solve this problem?

Thanks

[skatonni]

Try .Folders rather than .Items


Set rootFolder = rootFolder.Folders(arrFolders(I))

[westconn1]

removed

[Icek]

Try .Folders rather than .Items


Set rootFolder = rootFolder.Folders(arrFolders(I))

No, it doesn't work.

Now I have included a function to test if the folder is already created. If not, it has to be created:


Public Function GetFolder(strFolderPath As String) As MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arr() As String
Dim n As Long
On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arr() = Split(strFolderPath, "\")
Set objApp = Application
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arr(0))
If Not objFolder Is Nothing Then
For n = 1 To UBound(arr)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arr(n))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function

Sub AddFolders()

Dim myNameSpace As Outlook.NameSpace
Dim rootFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder
Dim strComputer As String
Dim arrFolders() As String
Dim I As Long

Set myNameSpace = Application.GetNamespace("MAPI")

Set fso = CreateObject("Scripting.FileSystemObject")
Set objInputFile = fso.OpenTextFile("C:\temp\test.txt", 1, True)

Do Until objInputFile.AtEndOfLine
strComputer = objInputFile.ReadLine
arrFolders() = Split(strComputer, "\")

Set rootFolder = myNameSpace.Folders("Root") '-> The account witnin Outlook which is not the main one

Set objFolder = GetFolder("Root\" + strComputer) '-> Check if the folder exists

' If the folder does not exist then we create it
If objFolder Is Nothing Then
For I = 0 To (UBound(arrFolders) - 1) '-> Buid the path until the second to last folder
Set rootFolder = rootFolder.Folders(arrFolders(I)) '-----------------------------------------> That line does not work
Next
Set myNewFolder = rootFolder.Foder.Add(arrFolders(I+1)) '-> Folder creation with the last element of the array
Erase arrFolders '-> array cleaning
End If

Loop
objInputFile.Close
Set rootFolder = Nothing
Set myNewFolder = Nothing
Set myNameSpace = Nothing

End Sub

Another idea? ;)

[westconn1]

i guess the problem with your original code was relying on error handling
assumes that if an error, then the folder already exists, but some other error may cause the folder to neither exist or get created
try like

Do Until objInputFile.AtEndOfLine
strComputer = objInputFile.ReadLine
arrFolders() = Split(strComputer, "\")

Set rootFolder = myNameSpace.Folders("Root")

For I = 0 To UBound(arrFolders)
for each f in rootfolder.folders
if lcase(f.name) = lcase(arrfolders(I)) then exit for
next
if f is nothing then Set f = rootFolder.Folders.Add(arrFolders(I))
Set rootFolder = f
Next

Erase arrFolders

Loop it should avoid trying to create existing folders, but allow any other errors, in folder creation, to halt execution
i seem to remember in previous versions there may be limits to path depths, i have no idea if outlook has limitations in how many folders can exist

there may be faster ways than to loop every folder to test if it exists, but if the time for execution is not a problem, then it does not matter

[Icek]

Thanks a lot for your answer. Your code is much more nice than mine.
Thus the code is now:


Sub AddFolders()

Dim myNameSpace As Outlook.NameSpace
Dim rootFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder
Dim f As Outlook.Folder
Dim strComputer As String
Dim arrFolders() As String
Dim I As Long

Set myNameSpace = Application.GetNamespace("MAPI")

Set fso = CreateObject("Scripting.FileSystemObject")
Set objInputFile = fso.OpenTextFile("C:\temp\test.txt", 1, True)

Do Until objInputFile.AtEndOfLine
strComputer = objInputFile.ReadLine
arrFolders() = Split(strComputer, "\")

Set rootFolder = myNameSpace.Folders("Root")

For I = 0 To UBound(arrFolders)
For Each f In rootFolder.Folders
If LCase(f.Name) = LCase(arrFolders(I)) Then Exit For
Next
If f Is Nothing Then Set f = rootFolder.Folders.Add(arrFolders(I))
Set rootFolder = f
Next

Erase arrFolders

Loop

objInputFile.Close
Set rootFolder = Nothing
Set myNewFolder = Nothing
Set myNameSpace = Nothing

End Sub

The macro stops after Folder1 is created with the merror message: "Impossible to create the folder".
I think that the code does not see that it has to skip the processed folder because it dos not see that the folder already exists.

[westconn1]

The macro stops after Folder1 is created with the merror message: "Impossible to create the folder"
what are the exact values of rootfolder.name and arrfolders(I) at the time the code stops?
some strings may not be a valid folder path name
what folders (if any) already exist under rootfolder?

I think that the code does not see that it has to skip the processed folder because it dos not see that the folder already exists.
if the folder exists then it should be found when looping all existing folders within a parent folder, so the folder can not be created for some other reason

how far through the process does the error occur?
the last line read of the text file may be a blank line
the last element of arrfolders may also not contain a valid value


post a sample of the textfile list of folders and i will test

[Icek]

Ok, the issue was that the loop worked too faster for the Exchange.
I mean that I added a sleep of 1 second between each folder creation and I have no more error message and the folders/subfolders are created as they should.
Here is the final working code:


Public Sub PauseApp(PauseInSeconds As Long)

Call AppSleep(PauseInSeconds * 1000)

End Sub
Sub AddFolders()

Dim myNameSpace As Outlook.NameSpace
Dim rootFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder
Dim f As Outlook.Folder
Dim strComputer As String
Dim arrFolders() As String
Dim I As Long

Set myNameSpace = Application.GetNamespace("MAPI")

Set fso = CreateObject("Scripting.FileSystemObject")
Set objInputFile = fso.OpenTextFile("C:\temp\test.txt", 1, True)

Do Until objInputFile.AtEndOfLine
strComputer = objInputFile.ReadLine
arrFolders() = Split(strComputer, "\")
Set rootFolder = myNameSpace.Folders("Root")

For I = 0 To UBound(arrFolders)
For Each f In rootFolder.Folders
If LCase(f.Name) = LCase(arrFolders(I)) Then Exit For
Next

If f Is Nothing Then Set f = rootFolder.Folders.Add(arrFolders(I))

Set rootFolder = f
PauseApp 1
Next

Erase arrFolders

Loop

objInputFile.Close
Set rootFolder = Nothing
Set myNewFolder = Nothing
Set myNameSpace = Nothing

MsgBox "Finished!"

End Sub

Thanks a lot for your help :)