Outlook 2007 - Count Emails by Date

Hello...I am trying to get count of emails read and unread by date.  
I have the counts..just need them by date....I have attached code.....thnks.
Sub TEST()
 
Dim objFolder As Outlook.Folder
Dim strPFPath As String
strPFPath = "myFolder_INFAV"
Set objFolder = GetPublicFolder(strPFPath)


MsgBox ("READ:  " & (objFolder.Items.count - objFolder.UnReadItemCount))
MsgBox ("UNREAD:  " & objFolder.UnReadItemCount)
MsgBox ("TOTAL:  " & objFolder.Items.count)



End Sub

Function GetPublicFolder(strPFPath)
    ' example: "Sales Department\Sales Contacts\NE Contacts"
    Dim objOL       ' As Outlook.Application
    Dim objNS       ' As Outlook.NameSpace
    Dim colFolders  ' As Outlook.Folders
    Dim objFolder   ' As Outlook.Folder
    Dim objFavRoot  ' As Outlook.Folder
    Dim arrFolders  ' As String - VBA should use arrFolders()
    Dim i           ' As Integer
    Dim j           ' As Integer
    Const olPublicFoldersAllPublicFolders = 18
    On Error Resume Next
    strPFPath = Replace(strPFPath, "/", "\")
    arrFolders = Split(strPFPath, "\")
    
     ' check Exchange online/offline status
    Set objOL = Application
    Set objNS = objOL.Session
    If objNS.Offline Then
     Else
        ' look in Public Folders\Favorites

        Set objFavRoot = GetPFFavs()
        Set colFolders = objFavRoot.Folders
        
        ' look for folder using full path
    
        ' look for folder using partial path
        If objFolder Is Nothing Then
            For i = UBound(arrFolders) To 0 Step -1
                Set colFolders = objFavRoot.Folders
                Set objFolder = Nothing
                Set objFolder = colFolders.Item(arrFolders(i))
                If Not objFolder Is Nothing Then
                    If i = UBound(arrFolders) Then
                        Exit For
                    Else
                        j = i
                        Do While j <= UBound(arrFolders)
                            j = j + 1
                            Set colFolders = objFolder.Folders
                            Set objFolder = Nothing
                            Set objFolder = _
                              colFolders.Item(arrFolders(j))
                            If Not objFolder Is Nothing Then
                                If j = UBound(arrFolders) Then
                                    Exit Do
                                End If
                            Else
                                Exit Do
                            End If
                        Loop
                        If Not objFolder Is Nothing Then
                            Exit For
                        End If
                    End If
                End If
            Next
        End If
    End If
    
    
    
    Set GetPublicFolder = objFolder
    Set objOL = Nothing
    Set objNS = Nothing
    Set colFolders = Nothing
    Set objFolder = Nothing
End Function

Function GetPFFavs()
    ' returns localized Public Folders\Favorites
    Dim objOL      ' As Outlook.Application
    Dim objNS      ' As Outlook.NameSpace
    Dim colFolders ' As Outlook.Folders
    Dim objFolder  ' As Outlook.Folder
    Dim objAllPF   ' As Outlook.Folder
    Dim objStore   ' As Outlook.Store
    Dim blnPFFound ' As Boolean
    Const olExchangePublicFolder = 2
    Const olPublicFoldersAllPublicFolders = 18
    On Error Resume Next
    Set objOL = Application
    Set objNS = objOL.Session
    For Each objStore In objNS.Stores
        If objStore.ExchangeStoreType = _
          olExchangePublicFolder Then
            blnPFFound = True
            Exit For
        End If
    Next
    If blnPFFound Then
        Set objFolder = objStore.GetRootFolder
        If objFolder.Folders.count = 1 Then
            Set GetPFFavs = objFolder.Folders.Item(1)
        Else
            Set objAllPF = objNS.GetDefaultFolder _
                            (olPublicFoldersAllPublicFolders)
            If objAllPF Is Nothing Then
                Set objFolder = objFolder.Folders.Item(1)
                If objFolder Is Nothing Then
                    Set objFolder = objFolder.Folders.Item(1)
                End If
                Set GetPFFavs = objFolder
            Else
                If objFolder.Folders.Item(1).EntryID = _
                  objAllPF.EntryID Then
                    Set GetPFFavs = objFolder.Folders.Item(2)
                Else
                    Set GetPFFavs = objFolder.Folders.Item(1)
                End If
            End If
        End If
    End If
    Set objOL = Nothing
    Set objNS = Nothing
    Set colFolders = Nothing
    Set objFolder = Nothing
    Set objAllPF = Nothing
    Set objStore = Nothing
End Function

Open in new window

TechMonsterAsked:
Who is Participating?
 
David LeeConnect With a Mentor Commented:
Hi, TechMoster.

This should do it.
Dim dicRead As Object, dicUnread As Object, objFolder As Object, objItems As Outlook.Items, objItem As Outlook.MailItem, strDate As String, intCount As Integer, strPFPath As String
Dim arrReadValues As Variant, arrReadKeys As Variant, strRead As String
Dim arrUnreadValues As Variant, arrUnreadKeys As Variant, strUnread As String
Set dicRead = CreateObject("Scripting.Dictionary")
Set dicUnread = CreateObject("Scripting.Dictionary")
strPFPath = "myFolder_INFAV"
Set objFolder = GetPublicFolder(strPFPath)
Set objItems = objFolder.Items
objItems.Sort "ReceivedTime"
For Each objItem In objFolder.Items
    strDate = Format(objItem.ReceivedTime, "mm/dd/yyyy")
    Select Case objItem.UnRead
        Case True
            If dicRead.Exists(strDate) Then
                dicRead.Item(strDate) = dicRead.Item(strDate) + 1
            Else
                dicRead.Add strDate, 1
            End If
        Case False
            If dicUnread.Exists(strDate) Then
                dicUnread.Item(strDate) = dicUnread.Item(strDate) + 1
            Else
                dicUnread.Add strDate, 1
            End If
    End Select
Next
arrReadValues = dicRead.Items()
arrReadKeys = dicRead.keys()
For intCount = LBound(arrReadKeys) To UBound(arrReadKeys)
    strRead = strRead & arrReadKeys(intCount) & " = " & arrReadValues(intCount) & vbCrLf
Next
msgbox strRead, vbInformation + vbOKOnly, "Read Message Count"
arrUnreadValues = dicUnread.Items()
arrUnreadKeys = dicUnread.keys()
For intCount = LBound(arrUnreadKeys) To UBound(arrUnreadKeys)
    strUnread = strUnread & arrUnreadKeys(intCount) & " = " & arrUnreadValues(intCount) & vbCrLf
Next
msgbox strUnread, vbInformation + vbOKOnly, "Unread Message Count"
Set dicRead = Nothing
Set dicUnread = Nothing
Set objFolder = Nothing
Set objItems = Nothing
Set objItem = Nothing

Open in new window

0
 
TechMonsterAuthor Commented:
This was a lot of help.  I was actually able to get the count of emails by day but was not able to figure out how to get the read and unread by date....appreciate it much.  thanks.
0
 
David LeeCommented:
You're welcome.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.