Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Outlook 2007 - Count Emails by Date

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

NEW Veeam Agent for Microsoft Windows

Backup and recover physical and cloud-based servers and workstations, as well as endpoint devices that belong to remote users. Avoid downtime and data loss quickly and easily for Windows-based physical or public cloud-based workloads!

Question has a verified solution.

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

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 …
By default Outlook 2016 displays only one time zone in the Calendar. The following article explains how to display two time zones in one calendar view.
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 …
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…

782 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