GetFolder Function - Add create new folder if missing

[jhowse]

Hi,

I'm pretty new VBA in outlook, and I am trying to create module that will allow me to move older emails from one folder to another, and if the destination folder does not exist, to create it..


I am using a version of the GetFolder Function by Microsoft for Outlook, which uses a text path string to create an Outlook.folder output to return to the calling sub..
The function works fine if the folder exists, but fails if I attempt to create a new folder that doesn't exit in the path with the following error:

An unexpected Error has occurred.
Error Number: 438
Error Description: Object doesn't support this property or method

I am hoping someone here can point out where my problem is in the code and how I can fix it..

TIA..

Function GetFolder(ByVal FolderPath As String) As Outlook.folder
Dim TestFolder As Outlook.folder
Dim FoldersArray As Variant
Dim i As Integer

On Error GoTo GetFolder_Error

Debug.Print "Org Folder Path: " & FolderPath
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
Debug.Print "New Folder Path: " & FolderPath
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set TestFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not TestFolder Is Nothing Then
Debug.Print "Base Folder Path: " & FoldersArray(0)
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = TestFolder.Folders
Debug.Print "Working Folder: " & FoldersArray(i)
On Error Resume Next

' If doesn`t exist create
If SubFolders.Item(FoldersArray(i)) Is Nothing Then
On Error GoTo GetFolder_Error
Debug.Print "Add Start" & vbCrLf
Set SubFolders = SubFolders.Folders.Add(FoldersArray(i))
Debug.Print "Folder Created" & vbCrLf
Set SubFolders = TestFolder.Folders
End If
Set TestFolder = SubFolders.Item(FoldersArray(i))
Next
End If

'Return the TestFolder
Set GetFolder = TestFolder
Debug.Print "Done" & vbCrLf
Set TestFolder = Nothing
Set FoldersArray = Nothing
Exit Function

GetFolder_Error:
Set GetFolder = Nothing
For j = 1 To UBound(FoldersArray, 1)
txt = txt & FoldersArray(j) & vbCrLf
Next j
Debug.Print vbCrLf & "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
& vbCrLf & "GetFolder Error [" & FoldersArray(i) & "]"
Exit Function
End Function

[skatonni]

This looks like the immediate problem.

'Set SubFolders = SubFolders.Folders.Add(FoldersArray(i))
Set SubFolders = SubFolders.Add(FoldersArray(i))

This looks like it creates folders as needed.

Option Explicit

Private Sub GetFolder_Test()

    Dim myFolder As Folder
    Dim myFolderPath As String
    myFolderPath = "\\" & "Your address" & "\Inbox\new"
    Set myFolder = GetFolder(myFolderPath)
    If Not (myFolder Is Nothing) Then
        ' Display myFolder in new window
         myFolder.Display
    End If
End Sub

Function GetFolder(ByVal FolderPath As String) As Folder

    Dim TestFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
    Dim j As Long
    Dim txt As String

    ' As the programmer, try not to use this, especially when debugging.
    ' Let the errors show up and highlight the line.
    ' On Error GoTo GetFolder_Error
    Debug.Print "Org Folder Path: " & FolderPath
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
        Debug.Print "New Folder Path: " & FolderPath
    End If
 
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set TestFolder = Application.Session.Folders.item(FoldersArray(0))
    
    If Not TestFolder Is Nothing Then
    
        Debug.Print "Base Folder Path: " & FoldersArray(0)
        For i = 1 To UBound(FoldersArray, 1)
        Dim SubFolders As Outlook.Folders
        Set SubFolders = TestFolder.Folders
        Debug.Print "Working Folder: " & FoldersArray(i)
        
        
        On Error Resume Next ' Bypass errors for a purpose
        ' If doesn`t exist create
        If SubFolders.item(FoldersArray(i)) Is Nothing Then
        'On Error GoTo GetFolder_Error
        Debug.Print "Add Start" & vbCrLf
        
        ' Especially important to have no unexpected errors, 
        '  such as a syntax error.
        'Set SubFolders = SubFolders.Folders.Add(FoldersArray(i))
        Set SubFolders = SubFolders.Add(FoldersArray(i))
     
        If Err = 0 Then
            Debug.Print "A folder should have been created." & vbCrLf
        End If
        On Error GoTo 0 ' To stop bypassing errors when the purpose is over
    
        Set SubFolders = TestFolder.Folders
        
    End If
    
    Set TestFolder = SubFolders.item(FoldersArray(i))
    
 Next
 
 End If
 'Return the TestFolder
 Set GetFolder = TestFolder
 
ExitRoutine:
    Debug.Print "Done" & vbCrLf
    Set TestFolder = Nothing
    Set FoldersArray = Nothing
    Exit Function

GetFolder_Error:
    Set GetFolder = Nothing
 
    ' This will generate errors
    '  by referring to missing FoldersArray data
    ' Limit yourself to the Err information
    '  if you use this error handling
    For j = 1 To UBound(FoldersArray, 1)
    txt = txt & FoldersArray(j) & vbCrLf
    Next j
    
    Debug.Print vbCrLf & "An unexpected Error has occurred." _
    & vbCrLf & "Error Number: " & Err.number _
    & vbCrLf & "Error Description: " & Err.Description _
    & vbCrLf & "GetFolder Error [" & FoldersArray(i) & "]"
 
    'Exit Function
    Resume ExitRoutine
 
 End Function

[jhowse]

Thanks.. That fixed it..
Thanks for the added advice on script debugging..