Solved

Outlook 2007 - Count Emails by Date

Posted on 2010-08-27
3
1,125 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

Control application downtime with dependency maps

Visualize the interdependencies between application components better with Applications Manager's automated application discovery and dependency mapping feature. Resolve performance issues faster by quickly isolating problematic components.

Question has a verified solution.

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

This process describes the steps required to Import and Export data from and to .pst files using Exchange 2010. We can use these steps to export data from a user to a .pst file, import data back to the same or a different user, or even import data t…
Is your Office 365 signature not working the way you want it to? Are signature updates taking up too much of your time? Let's run through the most common problems that an IT administrator can encounter when dealing with Office 365 email signatures.
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
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: …

867 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

Need Help in Real-Time?

Connect with top rated Experts

23 Experts available now in Live!

Get 1:1 Help Now