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