VeryForgetful
Board Regular
- Joined
- Mar 1, 2015
- Messages
- 242
Hi,
I'm looking to obtain some code that will loop through each email in my inbox and summarise the total count of emails per sender using the Outlook SenderEmailAddress property.
As well as this I am also looking for something that will loop through each email and show the total number of excel attachments that contain the word "template" in the filename and also the total number of attachments that contain picture files, note: some of the emails will have more than 1 attachment.
My inbox is huge so I would prefer if this could be done without extracting each attachment to a folder first.
I have some code that I use which lists total emails in my inbox and summarised it by date received, so not sure if I can modify this existing code to suite my needs?
Thanks
I'm looking to obtain some code that will loop through each email in my inbox and summarise the total count of emails per sender using the Outlook SenderEmailAddress property.
As well as this I am also looking for something that will loop through each email and show the total number of excel attachments that contain the word "template" in the filename and also the total number of attachments that contain picture files, note: some of the emails will have more than 1 attachment.
My inbox is huge so I would prefer if this could be done without extracting each attachment to a folder first.
I have some code that I use which lists total emails in my inbox and summarised it by date received, so not sure if I can modify this existing code to suite my needs?
Code:
Sub EmailCount()
Dim objOutlook As Object
Dim objnSpace As Object
Dim objFolder As MAPIFolder
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Dim NextRow As Long
Dim FirstRow As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.Folders("Personal Folders").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.Sort "[SentOn]", True
myItems.SetColumns "[SentOn]"
FirstRow = 2
ActiveSheet.Rows(FirstRow & ":" & ActiveSheet.Rows.Count).Clear
ActiveSheet.UsedRange.Borders.LineStyle = xlNone
For Each myItem In myItems
dateStr = GetDate(myItem.SentOn)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output dates that have emails
For Each o In dict.Keys
NextRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
msg = o
ActiveSheet.Range("A" & NextRow) = msg
Next
' Output email count per day:
For Each o In dict.Keys
NextRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row + 1
msg = dict(o)
ActiveSheet.Range("B" & NextRow) = msg
Next
With ActiveSheet.Range("A1").CurrentRegion
.HorizontalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.Borders.ColorIndex = xlAutomatic
End With
ActiveSheet.Columns.AutoFit
End Sub
Function GetDate(dt As Date) As String
GetDate = CDate(Day(dt) & "-" & Month(dt) & "-" & Year(dt))
End Function
Thanks