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..