Outlook Subfolder Expansion

[Phil_T123]

Hello,

I've got some code that is supposed to expand some folders in Outlook. It works fine for the first level folders, but won't expand the subfolders (in this case the xx Progressions folder).

The code doesn't bug out: the subfolder simply does not expand.

Could anybody tell me what I've done wrong?

Thanks!

Phil.

Private Sub ExpandFolders()

Dim objCurrentFolder As Outlook.Folder
Dim objStore As Outlook.Store
Dim objFileFolders As Outlook.Folders
Dim objFolder As Outlook.Folder
Dim objView As Outlook.View

DoEvents

'Expand xx Notifications
Set objStore = Outlook.Application.Session.Stores("xxNotification")
Set objFileFolders = objStore.GetRootFolder.Folders
Set Application.ActiveExplorer.CurrentFolder = objFileFolders("Inbox") 'Works fine

'Expand xx Delivery Support
Set objStore = Outlook.Application.Session.Stores("xxDeliverySupport")
Set objFileFolders = objStore.GetRootFolder.Folders
Set Application.ActiveExplorer.CurrentFolder = objFileFolders("Inbox")
Set Application.ActiveExplorer.CurrentFolder = objFileFolders("Inbox").Folders("xx Progressions") 'Does not expand

'User inbox
Set objStore = Outlook.Application.Session.Stores("xx.xx@xx.com")
Set objFileFolders = objStore.GetRootFolder.Folders
Set Application.ActiveExplorer.CurrentFolder = objFileFolders("Inbox") 'Works fine

End Sub