Loop through non-default Outlook folder

[BrI]

Trying to loop through mail items in a non-default Outlook folder but getting "Object Required" error before loop as shown below.

I'm quite uncertain about the syntax and any help appreciated.



Sub LoopFolder()


Dim objOL As Outlook.Application
Set objOL = CreateObject("Outlook.Application")

Dim objMsg As Outlook.MailItem

Dim strFolderPath As String
strFolderPath = "\\Mailbox - BC\Inbox\TestFolder"


Set objFolder = GetFolder_Z(strFolderPath)


For Each objMsg In objFolder '<------------------------- Error 424: Object Reqired
'Do Stuff in loop
Next objMsg


End Sub


Function GetFolder_Z(strFolderPath As String) As MAPIFolder


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


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


Set GetFolder_Z = objFolder

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

[gmayor]

Sorry - reply added to wrong message :(

[BrI]

For reference, I resolved this as below.


Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder

Set objNS = GetNamespace("MAPI")

Set objFolder = objNS.Folders("Mailbox - MyName").Folders("Inbox").Folders("Test Sub Folder")


For Each item In objFolder.Items

'Do stuff

Next

End Sub

[skatonni]

The original code may still be useful to you if you want to avoid typing in the multiple .Folders



Function GetFolder_Z(strFolderPath As String) As MAPIFolder

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long

On Error Resume Next

Debug.Print strFolderPath
' Drop \\ if passed into the function
strFolderPath = Replace(strFolderPath, "\\", "")
Debug.Print strFolderPath

' Fix possibly incorrectly facing slashes, when path is manually input
strFolderPath = Replace(strFolderPath, "/", "\") ' <--- Error was here
Debug.Print strFolderPath

arrFolders() = Split(strFolderPath, "\")

Set objApp = Application
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))

If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

' Stepping through from LoopFolder with F8
' you would have seen objFolder is nothing
Set GetFolder_Z = objFolder

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