?
Solved

Outlook 2007 - Count Emails by Date

Posted on 2010-08-27
3
Medium Priority
?
1,213 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 2000 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

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

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

Mailbox Corruption is a nightmare every Exchange DBA wishes he never has. Recovering from it can be super-hectic if not entirely futile. And though techniques like the New-MailboxRepairRequest cmdlet have been designed to help with fixing minor corr…
MS Outlook undoubtedly is the most widely used email client.Its user-friendliness, cost effectiveness, and availability with Microsoft Office Suite make it the most popular email application.  Its compatibility with Microsoft applications like Exch…
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: …
The video provides a quick and easy steps to migrate MBOX file to well known Outlook PST and Office 365. Besides this, it also supports and migrates more than 20 email clients of MBOX which include AppleMail, Opera, Thunderbird and SeaMonkey effortl…
Suggested Courses

601 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