TechMonster
asked on
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.
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
You're welcome.
ASKER