Solved

Outlook 2007 - Count Emails by Date

Posted on 2010-08-27
3
1,144 Views
Last Modified: 2012-05-10
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

0
Comment
Question by:TechMonster
  • 2
3 Comments
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 33550740
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
 

Author Comment

by:TechMonster
ID: 33559556
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
 
LVL 76

Expert Comment

by:David Lee
ID: 33562842
You're welcome.
0

Featured Post

Efficient way to get backups off site to Azure

This user guide provides instructions on how to deploy and configure both a StoneFly Scale Out NAS Enterprise Cloud Drive virtual machine and Veeam Cloud Connect in the Microsoft Azure Cloud.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Following basic email etiquette rules will help you write a professional email and achieve a good, lasting impression with your contacts.
You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

680 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question