Count emails by category in Outlook with VBA

[lharr28]

I'm trying to create a VBA that counts the number of mail items by category in Outlook. I found one already done but when I ran the code I got the error message that aitem and aKey were not defined so I defined them both as objects. Now when I run the code, the message box pops up, but it is empty. No information is listed.

I'm trying to figure out why the data won't display and also if I can get the data to display in something other than a message box, like maybe an excel file.

I've listed the code below:

Sub CategoriesEmails()

    Dim oFolder As MAPIFolder
    Dim oDict As Object
    Dim sStartDate As String
    Dim sEndDate As String
    Dim oItems As Outlook.Items
    Dim aitem As Object
    Dim sStr As String
    Dim sMsg As String
    Dim aKey As Object


    On Error Resume Next
    Set oFolder = Application.ActiveExplorer.CurrentFolder

    Set oDict = CreateObject("Scripting.Dictionary")

    sStartDate = InputBox("Type the start date (format MM/DD/YYYY)")
    sEndDate = InputBox("Type the end date (format MM/DD/YYYY)")

    Set oItems = oFolder.Items.Restrict("[Received] >= '" & sStartDate & "' And [Received] <= '" & sEndDate & "'")
    oItems.SetColumns ("Categories")

    For Each aitem In oItems
    sStr = aitem.Categories
    If Not oDict.Exists(sStr) Then
    oDict(sStr) = 0
    End If
    oDict(sStr) = CLng(oDict(sStr)) + 1
    Next aitem

    sMsg = ""
    For Each aKey In oDict.Keys
    sMsg = sMsg & aKey & ":   " & oDict(aKey) & vbCrLf
    Next
    MsgBox sMsg

    Set oFolder = Nothing

 End Sub

 

[Domenic]

A few issues . . .

1) The variable aKey should be declared as a Variant, not an Object.

2) The 'On Error Resume Next' statement is not really being used correctly. As it stands, it hides any and all errors.

3) The SetColumns method cannot be used with the Categories property, as per this article.

4) The code should allow for the user to cancel when prompted to enter a start and end date, and it should make sure that the user enters a valid date.

Try the following...

Option Explicit

Sub CategoriesEmails()

    Dim oDict As Object
    Dim aKey As Variant
    Dim oFolder As Outlook.MAPIFolder
    Dim oItems As Outlook.Items
    Dim aitem As Object
    Dim sStartDate As String
    Dim sEndDate As String
    Dim sStr As String
    Dim sMsg As String

    Do
        sStartDate = InputBox("Type the start date (format MM/DD/YYYY)")
        If StrPtr(sStartDate) = 0 Then Exit Sub
    Loop Until IsDate(sStartDate)
    
    Do
        sEndDate = InputBox("Type the end date (format MM/DD/YYYY)")
        If StrPtr(sEndDate) = 0 Then Exit Sub
    Loop Until IsDate(sEndDate)

    Set oFolder = Application.ActiveExplorer.CurrentFolder

    Set oItems = oFolder.Items.Restrict("[Received] >= '" & sStartDate & "' And [Received] <= '" & sEndDate & "'")
    
    If oItems.Count = 0 Then
        MsgBox "No items were found.", vbExclamation
        Exit Sub
    End If

    Set oDict = CreateObject("Scripting.Dictionary")

    For Each aitem In oItems
        sStr = aitem.Categories
        oDict(sStr) = oDict(sStr) + 1
    Next aitem

    sMsg = ""
    For Each aKey In oDict.Keys
        sMsg = sMsg & aKey & ":   " & oDict(aKey) & vbCrLf
    Next
    
    MsgBox sMsg, vbInformation

    Set oDict = Nothing
    Set oFolder = Nothing
    Set oItems = Nothing

 End Sub

Hope this helps!

 

[6StringJazzer]

Good catch on #3. This code worked for me. However, when I set the start and end date to the same date, I get 0 items even though the test is >= and <=. When I set the end date to the day after, I do get correct results of 24 categorized items that are all on the first day.

 

[Alex Blakenburg]

@6StringJazzer - Outlook is going to have date and time, try:

    Set oItems = oFolder.Items.Restrict("[Received] >= '" & sStartDate & "' And [Received] < '" & sEndDate + 1 & "'")

 

[Domenic]

@6StringJazzer

Actually, good catch on your part, thanks for letting me know, I really appreciate it.

@Alex Blakenburg

Actually, it gives a type mismatch error, but a slight modification to your solution seems to work...

    Set oItems = oFolder.Items.Restrict("[Received] >= '" & sStartDate & "' And [Received] < '" & Format(CDate(sEndDate) + 1, "mm/dd/yyyy") & "'")