Sub CountItems() Dim objMainFolder As Outlook.Folder Dim lItemsCount As Long 'Select a folder Set objMainFolder = Outlook.Application.Session.PickFolder If objMainFolder Is Nothing Then MsgBox "You should select a valid folder!", vbExclamation + vbOKOnly, "Warning for Pick Folder" Else 'Initialize the total count lItemsCount = 0 Call LoopFolders(objMainFolder, lItemsCount) End If 'Display a message for the total count MsgBox "There are " & lItemsCount & " items in the " & objMainFolder.Name & " folder Including its subfolders.", vbInformation, "Count Items" End Sub Sub LoopFolders(ByVal objCurrentFolder As Outlook.Folder, lCurrentItemsCount As Long) Dim objSubfolder As Outlook.Folder lCurrentItemsCount = lCurrentItemsCount + objCurrentFolder.Items.Count 'Process all folders and subfolders recursively If objCurrentFolder.Folders.Count Then For Each objSubfolder In objCurrentFolder.Folders Call LoopFolders(objSubfolder, lCurrentItemsCount) Next End If End Sub