Outlook Folders and Mail count

[stuartjohnwood]

Gentlefolks,

I need an Outlook VBA that can export a list of my Outlook folders and sub folders with a count of how many mails are within each. I know all that info is available but have no idea how to go about stringing it together.

Any help from out there would be hugely appreciated.

Best regards

SJW

 

[Ruddles]

<deleted>

 

[Ruddles]

Let me try again!

Create a new workbook and paste this code into a new standard module. Go Tools > References and add Microsoft Outlook Objects Library. Run ListFolders.

[FONT=Fixedsys]Option Explicit[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]Dim ws As Worksheet
Dim iRow As Integer
Const bTitles As Boolean = True [COLOR=green]' do we want column titles?[/COLOR][/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]Public Sub ListFolders()[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]  Dim objNS As Outlook.Namespace
  
  Set ws = ThisWorkbook.Sheets("Sheet1")
  Set objNS = Outlook.Application.GetNamespace("MAPI")
  
  ws.UsedRange.ClearContents
  iRow = IIf(bTitles, 1, 0)
  If bTitles Then ws.Range("A1:D1") = Array("Folder Path & Name", "Items", "", "Indented List Of Folders")
  ws.Range("A1:D1").Font.Bold = bTitles
  
  ListFromFolder objNS, 1, ""
  
  ws.Cells(iRow + 1, 2) = "=SUM(B" & IIf(bTitles, "2", "1") & ":B" & CStr(iRow) & ")"
  ws.UsedRange.ColumnWidth = 4
  ws.Columns("A:B").AutoFit
  
  MsgBox "Done:-" & vbCrLf & vbCrLf _
       & CStr(iRow - IIf(bTitles, 1, 0)) & " folders listed" & Space(15) & vbCrLf & vbCrLf _
       & Format(ws.Cells(iRow + 1, 2), "#,##0") & " items counted", _
       vbOKOnly + vbInformation
  
  Set objNS = Nothing
  Set ws = Nothing
  
End Sub[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]Private Sub ListFromFolder(objFolderRoot As Object, argLevel As Integer, argFullName As String)[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]  Dim objFolder As MAPIFolder
  
  For Each objFolder In objFolderRoot.Folders
    DoEvents
    iRow = iRow + 1
    ' full folder path in column A
    ws.Cells(iRow, 1) = argFullName & "\" & objFolder.Name
    ' count of items in folder in column B
    On Error Resume Next
    ws.Cells(iRow, 2) = objFolder.Items.Count
    On Error GoTo 0
    ' indented folder list in column C onwards
    ws.Cells(iRow, argLevel + 3) = objFolder.Name
    If objFolder.Folders.Count > 0 Then
      ListFromFolder objFolder, argLevel + 1, argFullName & "\" & objFolder.Name[/FONT]
[FONT=Fixedsys]    End If
  Next objFolder 
  
  Set objFolder = Nothing[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]End Sub[/FONT]

 

[stuartjohnwood]

Awesome - that is exactly what I was after!

Thank you so much for your help.

SJW

 

[stuartjohnwood]

Just on the off chance,

Is there a way to modify this formula to change the order in which it works through the folders?

ie first it runs through all the Public folders (of which in my case, there are over 9000) before getting to my mailbox folders.

Ideally, I'd want to do my folders first.

Stuart

 

[Ruddles]

Not as far as I'm aware. You could sort the worksheet but that's not the same thing at all, I accept.

 

[rrvann]

Hi,
I know this is an old thread, however, I have a question and I am hoping someone maybe able to answer it for me. I used the code above and it worked brillantly. I do not write code and I am wondering if code can be added to this one that will also pull the oldest email date from each folder. I would greatly appreciate your help. Thanks

Let me try again!

Create a new workbook and paste this code into a new standard module. Go Tools > References and add Microsoft Outlook Objects Library. Run ListFolders.

[FONT=Fixedsys]Option Explicit[/FONT]
 
[FONT=Fixedsys]Dim ws As Worksheet
Dim iRow As Integer
Const bTitles As Boolean = True [COLOR=green]' do we want column titles?[/COLOR][/FONT]
 
[FONT=Fixedsys]Public Sub ListFolders()[/FONT]
 
[FONT=Fixedsys] Dim objNS As Outlook.Namespace
  
  Set ws = ThisWorkbook.Sheets("Sheet1")
  Set objNS = Outlook.Application.GetNamespace("MAPI")
  
  ws.UsedRange.ClearContents
  iRow = IIf(bTitles, 1, 0)
  If bTitles Then ws.Range("A1:D1") = Array("Folder Path & Name", "Items", "", "Indented List Of Folders")
  ws.Range("A1:D1").Font.Bold = bTitles
  
  ListFromFolder objNS, 1, ""
  
  ws.Cells(iRow + 1, 2) = "=SUM(B" & IIf(bTitles, "2", "1") & ":B" & CStr(iRow) & ")"
  ws.UsedRange.ColumnWidth = 4
  ws.Columns("A:B").AutoFit
  
  MsgBox "Done:-" & vbCrLf & vbCrLf _
       & CStr(iRow - IIf(bTitles, 1, 0)) & " folders listed" & Space(15) & vbCrLf & vbCrLf _
       & Format(ws.Cells(iRow + 1, 2), "#,##0") & " items counted", _
       vbOKOnly + vbInformation
  
  Set objNS = Nothing
  Set ws = Nothing
  
End Sub[/FONT]
 
[FONT=Fixedsys]Private Sub ListFromFolder(objFolderRoot As Object, argLevel As Integer, argFullName As String)[/FONT]
 
[FONT=Fixedsys] Dim objFolder As MAPIFolder
  
  For Each objFolder In objFolderRoot.Folders
    DoEvents
    iRow = iRow + 1
    ' full folder path in column A
    ws.Cells(iRow, 1) = argFullName & "\" & objFolder.Name
    ' count of items in folder in column B
    On Error Resume Next
    ws.Cells(iRow, 2) = objFolder.Items.Count
    On Error GoTo 0
    ' indented folder list in column C onwards
    ws.Cells(iRow, argLevel + 3) = objFolder.Name
    If objFolder.Folders.Count > 0 Then
      ListFromFolder objFolder, argLevel + 1, argFullName & "\" & objFolder.Name[/FONT]
[FONT=Fixedsys]   End If
  Next objFolder 
  
  Set objFolder = Nothing[/FONT]
 
[FONT=Fixedsys]End Sub[/FONT]