vba to show total email count using SenderEmailAddress

[VeryForgetful]

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?

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

 

[VeryForgetful]

I now have the majority of this sorted out, but there is one additional thing I need.

I need to count the number of emails in my inbox that have picture attachments (bmp and jpeg). I can find a way to count the total number of attachments for these file types but I need to count the number of emails instead.

Any suggestions?