Excel - Outlook - count number of mail

N

neveu

Board Regular
Joined
Jan 27, 2009
Messages
225
hello Forum,

yet another interesting problem i would need you help to:

i'm trying to count the number of email recieved and send for the last year.

i was trying to somehow howload the list of emails send and recieved and then based on the timestamp to count the emails for each month.

do you have any ideas how i can do this?

thank you,
neveu
 
Sort by date Sort by votes
I posted this a couple of days ago. Did you try searching the forum?

Paste this into a new standard code module, change the bits in red to suit your system, add a reference to the Microsoft Outlook Objects Library (Tools > References), and run the code.

It will dump the details of all your mail onto a worksheet from where you can produce whatever stats you need. If you want it to do something different, look for the procedure ProcessItems and modify the code in the block If TypeOf MailObject Is MailItem Then..End If.

Code: 
[FONT=Courier New]Option Explicit[/FONT]
 
[FONT=Courier New]Dim RootFolder As String[/FONT]
[FONT=Courier New]Dim OlApp As Outlook.Application[/FONT]
[FONT=Courier New]Dim oMAPI As Outlook.Namespace[/FONT]
[FONT=Courier New]Dim oParentFolder As Outlook.MAPIFolder[/FONT]
[FONT=Courier New]Dim ws As Worksheet[/FONT]
[FONT=Courier New]Dim intTotalItems As Long[/FONT]
[FONT=Courier New]Dim intRowPointer As Long[/FONT]
 
[FONT=Courier New]Public Sub GetOutlookMail()[/FONT]
 
[FONT=Courier New] Dim dteTimer As Date[/FONT]
 
[FONT=Courier New] RootFolder = "[COLOR=red][B]Mailbox - SURNAME, Forename[/B][/COLOR]"[/FONT]
 
[FONT=Courier New] dteTimer = Now()[/FONT]
 
[FONT=Courier New] Set ws = ThisWorkbook.Sheets("[COLOR=red][B]Sheet1[/B][/COLOR]")[/FONT]
[FONT=Courier New] Set OlApp = CreateObject("Outlook.Application")[/FONT]
[FONT=Courier New] Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")[/FONT]
[FONT=Courier New] Set oParentFolder = oMAPI.Folders(RootFolder)[/FONT]
 
[FONT=Courier New] intTotalItems = 0[/FONT]
[FONT=Courier New] Call CountAllItems(oParentFolder)[/FONT]
[FONT=Courier New] ws.Columns("A:S").ClearContents[/FONT]
 
[FONT=Courier New] Call ColumnHeaders[/FONT]
 
[FONT=Courier New] intRowPointer = 2[/FONT]
[FONT=Courier New] Application.Cursor = xlWait[/FONT]
[FONT=Courier New] Call ProcessFolder(oParentFolder)[/FONT]
[FONT=Courier New] Application.Cursor = xlDefault[/FONT]
 
[FONT=Courier New] MsgBox "Done: " & CStr(intTotalItems) & " items (" & Format(dteTimer - Now(), "hh:nn:ss") & ")"[/FONT]
 
[FONT=Courier New] Set OlApp = Nothing[/FONT]
 
[FONT=Courier New]End Sub[/FONT]
 
[FONT=Courier New]Private Sub CountAllItems(StartFolder As Outlook.MAPIFolder)[/FONT]
 
[FONT=Courier New] Dim uFolder As Outlook.MAPIFolder[/FONT]
[FONT=Courier New] Dim MailObject As Object[/FONT]
 
[FONT=Courier New] If StartFolder.DefaultItemType = 0 And StartFolder.FolderPath <> "\\" & RootFolder Then[/FONT]
[FONT=Courier New]     intTotalItems = intTotalItems + StartFolder.Items.Count[/FONT]
[FONT=Courier New] End If[/FONT]
[FONT=Courier New] If StartFolder.DefaultItemType = 0 Then[/FONT]
[FONT=Courier New]   For Each uFolder In StartFolder.Folders[/FONT]
[FONT=Courier New]     Call CountAllItems(uFolder)[/FONT]
[FONT=Courier New]   Next uFolder[/FONT]
[FONT=Courier New] End If[/FONT]
 
[FONT=Courier New] Set uFolder = Nothing[/FONT]
 
[FONT=Courier New]End Sub[/FONT]
 
[FONT=Courier New]Private Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)[/FONT]
 
[FONT=Courier New] Dim uFolder As Outlook.MAPIFolder[/FONT]
 
[FONT=Courier New] If StartFolder.DefaultItemType = 0 Then[/FONT]
[FONT=Courier New]   Call ProcessItems(StartFolder, StartFolder.Items)[/FONT]
[FONT=Courier New]   For Each uFolder In StartFolder.Folders[/FONT]
[FONT=Courier New]     Call ProcessFolder(uFolder)[/FONT]
[FONT=Courier New]   Next uFolder[/FONT]
[FONT=Courier New] End If[/FONT]
 
[FONT=Courier New] Set uFolder = Nothing[/FONT]
 
[FONT=Courier New]End Sub[/FONT]
 
[FONT=Courier New]Private Sub ProcessItems(CurrentFolder As Outlook.MAPIFolder, Collection As Outlook.Items)[/FONT]
 
[FONT=Courier New] Dim MailObject As Object[/FONT]
[FONT=Courier New] Dim intAttachment As Integer[/FONT]
 
[FONT=Courier New] For Each MailObject In Collection[/FONT]
[FONT=Courier New]   DoEvents[/FONT]
[FONT=Courier New]   If TypeOf MailObject Is MailItem Then[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 1) = MailObject.SentOn[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 2) = MailObject.SenderName[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 3) = MailObject.SenderEmailAddress[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 4) = MailObject.SentOnBehalfOfName[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 5) = MailObject.To[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 6) = MailObject.CC[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 7) = MailObject.BCC[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 8) = MailObject.ReceivedByName[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 9) = MailObject.ReceivedOnBehalfOfName[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 10) = MailObject.ReplyRecipientNames[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 11) = MailObject.Subject[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 12) = MailObject.Body[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 13) = MailObject.HTMLBody[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 14) = MailObject.Importance[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 15) = MailObject.Attachments.Count[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 16) = ""[/FONT]
[FONT=Courier New]     For intAttachment = 1 To MailObject.Attachments.Count[/FONT]
[FONT=Courier New]       ws.Cells(intRowPointer, 16) = ws.Cells(intRowPointer, 16) & ";" & MailObject.Attachments(intAttachment).Filename[/FONT]
[FONT=Courier New][COLOR=green]       ' we may want to save some or all of the attachments[/COLOR][/FONT]
[FONT=Courier New][COLOR=green]       ' MailObject.Attachments(intAttachment).SaveAsFile "C:\Temp\" & MailObject.Attachments(intAttachment).FileName[/COLOR][/FONT]
[FONT=Courier New]     Next intAttachment[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 16) = Mid(ws.Cells(intRowPointer, 16), 2) ' remove leading semicolon[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 17) = CurrentFolder.FolderPath[/FONT]
[FONT=Courier New]     ws.Cells(intRowPointer, 18) = CurrentFolder.Name[/FONT]
[FONT=Courier New]     If MailObject.UnRead Then[/FONT]
[FONT=Courier New]       ws.Cells(intRowPointer, 19) = "N"[/FONT]
[FONT=Courier New]     Else[/FONT]
[FONT=Courier New]       ws.Cells(intRowPointer, 19) = "Y"[/FONT]
[FONT=Courier New]     End If[/FONT]
[FONT=Courier New]     intRowPointer = intRowPointer + 1[/FONT]
[FONT=Courier New]   End If[/FONT]
[FONT=Courier New] Next MailObject[/FONT]
 
[FONT=Courier New] Set MailObject = Nothing[/FONT]
 
[FONT=Courier New]End Sub[/FONT]
 
[FONT=Courier New]Private Sub ColumnHeaders()[/FONT]
 
[FONT=Courier New] Dim ColumnHeads As Variant[/FONT]
 
[FONT=Courier New] ColumnHeads = Array("SenderName", "SenderEmailAddress", "SentOnBehalfOfName", "To", "CC", _[/FONT]
[FONT=Courier New]       "BCC", "ReceivedByName", "ReceivedOnBehalfOfName", "ReplyRecipientNames", "Subject", _[/FONT]
[FONT=Courier New]       "SentOn", "Body", "HTMLBody", "Importance", "AttachmentsCount", "Attachments", _[/FONT]
[FONT=Courier New]       "FolderPath", "FolderName", "Read")[/FONT]
 
[FONT=Courier New] ws.Range("A1").Resize(1, UBound(ColumnHeads) + 1) = ColumnHeads[/FONT]
[FONT=Courier New] Rows("2").Select[/FONT]
[FONT=Courier New] With ActiveWindow[/FONT]
[FONT=Courier New]   .SplitColumn = 0[/FONT]
[FONT=Courier New]   .SplitRow = 1[/FONT]
[FONT=Courier New] End With[/FONT]
[FONT=Courier New] ActiveWindow.FreezePanes = True[/FONT]
 
[FONT=Courier New] ws.Rows("1").Font.Bold = True[/FONT]
 
[FONT=Courier New]End Sub[/FONT]
 
Upvote 0
Hello Rudd,

thank you very much for the code.

i've modified as per your inputs but i get the an error at the bolded lines in the code: "Run-time rror '1004'" Method 'ThisWorkbook' of object'_Global' failed".

how can it be fixed ? where does the workbook have to be created? - i've put in on my desktop and named on of the spreadsheets "mails".

Rich (BB code): 
Option Explicit
 
Dim RootFolder As String
Dim OlApp As Outlook.Application
Dim oMAPI As Outlook.NameSpace
Dim oParentFolder As Outlook.MAPIFolder
Dim ws As Worksheet
Dim intTotalItems As Long
Dim intRowPointer As Long
 
Public Sub GetOutlookMail()
 
 Dim dteTimer As Date
 
 RootFolder = "New_PST"
 
 dteTimer = Now()
 
 Set ws = ThisWorkbook.Sheets("mails")
 Set OlApp = CreateObject("Outlook.Application")
 Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
 Set oParentFolder = oMAPI.Folders(RootFolder)
 
 intTotalItems = 0
 Call CountAllItems(oParentFolder)
 ws.Columns("A:S").ClearContents
 
 Call ColumnHeaders
 
 intRowPointer = 2
 Application.Cursor = xlWait
 Call ProcessFolder(oParentFolder)
 Application.Cursor = xlDefault
 
 MsgBox "Done: " & CStr(intTotalItems) & " items (" & Format(dteTimer - Now(), "hh:nn:ss") & ")"
 
 Set OlApp = Nothing
 
End Sub
 
Private Sub CountAllItems(StartFolder As Outlook.MAPIFolder)
 
 Dim uFolder As Outlook.MAPIFolder
 Dim MailObject As Object
 
 If StartFolder.DefaultItemType = 0 And StartFolder.FolderPath <> "\\" & RootFolder Then
     intTotalItems = intTotalItems + StartFolder.Items.Count
 End If
 If StartFolder.DefaultItemType = 0 Then
   For Each uFolder In StartFolder.Folders
     Call CountAllItems(uFolder)
   Next uFolder
 End If
 
 Set uFolder = Nothing
 
End Sub
 
Private Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
 
 Dim uFolder As Outlook.MAPIFolder
 
 If StartFolder.DefaultItemType = 0 Then
   Call ProcessItems(StartFolder, StartFolder.Items)
   For Each uFolder In StartFolder.Folders
     Call ProcessFolder(uFolder)
   Next uFolder
 End If
 
 Set uFolder = Nothing
 
End Sub
 
Private Sub ProcessItems(CurrentFolder As Outlook.MAPIFolder, Collection As Outlook.Items)
 
 Dim MailObject As Object
 Dim intAttachment As Integer
 
 For Each MailObject In Collection
   DoEvents
   If TypeOf MailObject Is MailItem Then
     ws.Cells(intRowPointer, 1) = MailObject.SentOn
     ws.Cells(intRowPointer, 2) = MailObject.SenderName
     ws.Cells(intRowPointer, 3) = MailObject.SenderEmailAddress
     ws.Cells(intRowPointer, 4) = MailObject.SentOnBehalfOfName
     ws.Cells(intRowPointer, 5) = MailObject.To
     ws.Cells(intRowPointer, 6) = MailObject.CC
     ws.Cells(intRowPointer, 7) = MailObject.BCC
     ws.Cells(intRowPointer, 8) = MailObject.ReceivedByName
     ws.Cells(intRowPointer, 9) = MailObject.ReceivedOnBehalfOfName
     ws.Cells(intRowPointer, 10) = MailObject.ReplyRecipientNames
     ws.Cells(intRowPointer, 11) = MailObject.Subject
     ws.Cells(intRowPointer, 12) = MailObject.Body
     ws.Cells(intRowPointer, 13) = MailObject.HTMLBody
     ws.Cells(intRowPointer, 14) = MailObject.Importance
     ws.Cells(intRowPointer, 15) = MailObject.Attachments.Count
     ws.Cells(intRowPointer, 16) = ""
     For intAttachment = 1 To MailObject.Attachments.Count
       ws.Cells(intRowPointer, 16) = ws.Cells(intRowPointer, 16) & ";" & MailObject.Attachments(intAttachment).FileName
       ' we may want to save some or all of the attachments
       ' MailObject.Attachments(intAttachment).SaveAsFile "C:\Temp\" & MailObject.Attachments(intAttachment).FileName
     Next intAttachment
     ws.Cells(intRowPointer, 16) = Mid(ws.Cells(intRowPointer, 16), 2) ' remove leading semicolon
     ws.Cells(intRowPointer, 17) = CurrentFolder.FolderPath
     ws.Cells(intRowPointer, 18) = CurrentFolder.Name
     If MailObject.UnRead Then
       ws.Cells(intRowPointer, 19) = "N"
     Else
       ws.Cells(intRowPointer, 19) = "Y"
     End If
     intRowPointer = intRowPointer + 1
   End If
 Next MailObject
 
 Set MailObject = Nothing
 
End Sub
 
Private Sub ColumnHeaders()
 
 Dim ColumnHeads As Variant
 
 ColumnHeads = Array("SenderName", "SenderEmailAddress", "SentOnBehalfOfName", "To", "CC", _
       "BCC", "ReceivedByName", "ReceivedOnBehalfOfName", "ReplyRecipientNames", "Subject", _
       "SentOn", "Body", "HTMLBody", "Importance", "AttachmentsCount", "Attachments", _
       "FolderPath", "FolderName", "Read")
 
 ws.Range("A1").Resize(1, UBound(ColumnHeads) + 1) = ColumnHeads
 Rows("2").Select
 With ActiveWindow
   .SplitColumn = 0
   .SplitRow = 1
 End With
 ActiveWindow.FreezePanes = True
 
 ws.Rows("1").Font.Bold = True
 
End Sub
 
Upvote 0
RootFolder needs to point at your top level mail folder. The code needs to be in a standard code module rather than a worksheet code module. The workbook can be anywhere.

Try changing the faulty line to Set ws = ActiveWorkbook.Sheets("mails") or Set ws = Sheets("mails").
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
Is there any way to processing the data in the mail to Excell
Replies
1
Views
63
rowebca
rowebca
A
  • Question Question
VBA Outlook email
Replies
1
Views
91
John_w
J
J
  • Question Question
Send bulk email attachment error
Replies
3
Views
300
JOHATUP
J
G
  • Question Question
Modify Single Email in Outlook Drafts subfolder
Replies
1
Views
450
g_speran
G
L
  • Question Question
Count emails by category in Outlook with VBA
Replies
4
Views
316
Domenic
D

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top