Check if an outlook folder exists; if not create it

Question

Im trying to check if a folder exists; if it does not then create it. The below is just throwing a run-time error.

 Sub AddClose()
 Dim myNameSpace As Outlook.NameSpace
 Dim myFolder As Outlook.Folder
 Dim myNewFolder As Outlook.Folder
 Set myNameSpace = Application.GetNamespace("MAPI")
 Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)

            If myFolder.Folders("Close") = 0 Then
                myFolder.Folders.Add("Close").Folders.Add ("EID1")
                myFolder.Folders("Close").Folders.Add ("EID2")
                myFolder.Folders("Close").Folders.Add ("EID3")

            End If
End Sub

However, If the folder exists then the below works...

If myFolder.Folders("Close") > 0 Then
    MsgBox "Yay!"            
End If

Why? What can I do to correct the problem?

Answer 1

Firstly, you are comparing the result of the myFolder.Folders("Close") call (which is supposed to return a MAPIFolder object) with an integer (0). You need to use Is Nothing or Is Not Nothing operator.

Secondly, MAPIFolder.Folders.Item() raises an exception if the folder with a given name is not found. You need to trap that exception (as ugly as it is in VBA) and either check the Err.Number value or check that the return object is set:

On Error Resume Next
set subFolder = myFolder.Folders.Item("Close")
if subFolder Is Nothing Then
  set subFolder = myFolder.Folders.Add("Close")
End If

Answer 2

I do not understand: If myFolder.Folders("Close") = 0 Then. myFolder.Folders("Close") is a folder and I would not have thought of comparing it against zero. Do you have a reference to a site where this functionality is explained because I would like to understand it?

I wish to create a folder if it does not exist often enough to have written a function. My function does not have ideal parameters for your requirement but it works. I offer it as tested code that does what you want or as a source of ideas for your own code.

Sub DemoGetCreateFldr shows how to use the function GetCreateFldr to achieve the effect I believe you seek.

I do not use GetDefaultFolder because, on my system, it returns a reference to a store I do not use. “Outlook Data File” is Outlook’s default store but the wizard created a separate store for each of my two email addresses. In Set Store = Session.Folders("Outlook Data File"), replace "Outlook Data File" with the name of the store holding the Inbox for which you want to create subfolders.

The first call of GetCreateFldr creates folder “Close” if it does not exist and then creates folder “EID1”. I save the reference to the folder, and use Debug.Print to demonstrate it returns the correct reference.

For folders “EID2” and “EID3”, I do not save the reference which matches your code.

If folders “Close”, “EID1”, “EID2” and “EID3” exist, GetCreateFldr does not attempt to create them although it still returns a reference.

Hope this helps.

Sub DemoGetCreateFldr()

  Dim FldrEID1 As Folder
  Dim FldrNameFull(1 To 3) As String
  Dim Store As Folder

  Set Store = Session.Folders("Outlook Data File")

  FldrNameFull(1) = "Inbox"
  FldrNameFull(2) = "Close"

  FldrNameFull(3) = "EID1"
  Set FldrEID1 = GetCreateFldr(Store, FldrNameFull)
  Debug.Print FldrEID1.Parent.Parent.Parent.Name & "|" & _
              FldrEID1.Parent.Parent.Name & "|" & _
              FldrEID1.Parent.Name & "|" & _
              FldrEID1.Name

  FldrNameFull(3) = "EID2"
  Call GetCreateFldr(Store, FldrNameFull)

  FldrNameFull(3) = "EID3"
  Call GetCreateFldr(Store, FldrNameFull)

End Sub
Public Function GetCreateFldr(ByRef Store As Folder, _
                              ByRef FldrNameFull() As String) As Folder

  ' * Store identifies the store, which must exist, in which the folder is
  '   wanted.
  ' * FldrNameFull identifies a folder which is or is wanted within Store.
  '   Find the folder if it exists otherwise create it. Either way, return
  '   a reference to it.

  ' * If LB is the lower bound of FldrNameFull:
  '     * FldrNameFull(LB) is the name of a folder that is wanted within Store.
  '     * FldrNameFull(LB+1) is the name of a folder that is wanted within
  '       FldrNameFull(LB).
  '     * FldrNameFull(LB+2) is the name of a folder that is wanted within
  '       FldrNameFull(LB+1).
  '     * And so on until the full name of the wanted folder is specified.

  ' 17Oct16  Date coded not recorded but must be before this date

  Dim FldrChld As Folder
  Dim FldrCrnt As Folder
  Dim ChildExists As Boolean
  Dim InxC As Long
  Dim InxFN As Long

  Set FldrCrnt = Store

  For InxFN = LBound(FldrNameFull) To UBound(FldrNameFull)
    ChildExists = True
    ' Is FldrNameFull(InxFN) a child of FldrCrnt?
    On Error Resume Next
    Set FldrChld = Nothing   ' Ensure value is Nothing if following statement fails
    Set FldrChld = FldrCrnt.Folders(FldrNameFull(InxFN))
    On Error GoTo 0
    If FldrChld Is Nothing Then
      ' Child does not exist
      ChildExists = False
      Exit For
    End If
    Set FldrCrnt = FldrChld
  Next

  If ChildExists Then
    ' Folder already exists
  Else
    ' Folder does not exist. Create it and any children
    Set FldrCrnt = FldrCrnt.Folders.Add(FldrNameFull(InxFN))
    For InxFN = InxFN + 1 To UBound(FldrNameFull)
      Set FldrCrnt = FldrCrnt.Folders.Add(FldrNameFull(InxFN))
    Next
  End If

  Set GetCreateFldr = FldrCrnt

End Function

Answer 3

Its not a good coding practice to user on error.
I would recommend you to traverse through the folders.
Then if a certain name is not found create it.
The code below part of my macro I use.
It looks for a "Duplicates" under inbox.
It intentionally doesn't do this recursively.

Sub createDuplicatesFolder()
  Dim folderObj, rootfolderObj, newfolderObj As Outlook.folder
  Dim NameSpaceObj As Outlook.NameSpace

  duplicatefolder = False
  For Each folderObj In Application.Session.Folders
    If folderObj.Name = "Duplicates" Then duplicatefolder = True
    Next
  If duplicatefolder = False Then
     Set rootfolderObj = NameSpaceObj.GetDefaultFolder(olFolderInbox)
     Set newfolderObj = rootfolderObj.Folders.Add("Duplicates")
End Sub

Answer 4

A slow way. Depends on number of folders.

Sub checkFolder()

    Dim folderObj As folder
    Dim rootfolderObj As folder
    Dim newfolderObj As folder
    
    Dim checkFolderName As String
        
    ' Check and add in the same location
    Set rootfolderObj = Session.GetDefaultFolder(olFolderInbox)
    
    ' Check and add the same folder name
    checkFolderName = "checkedFolder"
    
    For Each folderObj In rootfolderObj.folders
        If folderObj.name = checkFolderName Then
            Set newfolderObj = rootfolderObj.folders(checkFolderName)
            
            'Reduces the search time, if the folder exists
            Exit For
            
        End If
    Next
    
    If newfolderObj Is Nothing Then
        Set newfolderObj = rootfolderObj.folders.add(checkFolderName)
    End If
    
    Debug.Print newfolderObj.name
    
End Sub

Answer 5

A fast way. Add without checking existing folders.

Sub addFolder_OnErrorResumeNext()

    Dim rootFolder As folder
    Dim addFolder As folder
    
    Dim addFolderName As String
    
    Set rootFolder = Session.GetDefaultFolder(olFolderInbox)
    addFolderName = "addFolder"
    
    On Error Resume Next
    ' Bypass expected error if folder exists
    Set addFolder = rootFolder.folders.add(addFolderName)
    ' Return to normal error handling for unexpected errors
    ' Consider mandatory after On Error Resume Next
    On Error GoTo 0
    
    ' In other cases the expected error should be handled.
    ' For this case it can be ignored.
    Set addFolder = rootFolder.folders(addFolderName)
    
    Debug.Print addFolder.name
    
End Sub