auto_mach
05-03-2015, 07:51 PM
Hi, everyone!
I found this code elsewhere online and modified it to fit my needs, but I need some help to get the last kink out of it.
For some more info on my needs, I have to check several mailboxes at work for a daily report and this code does everything I need save for one little thing.
As you can see, I exclude all emails marked as "completed." Since these mailboxes are handled by other parties, I'm unable to run rules and move the emails myself. I am only able to count them for my report.
Sub email_count()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer, CompCount As Integer
Dim strFolder As String
Dim olMailItem As Outlook.MailItem
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
CompCount = 0
On Error Resume Next
Set objFolder = Application.GetNamespace("MAPI").Folders("Mailbox Name").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
strFolder = objFolder.Parent
EmailCount = objFolder.Items.Count
For Each olMailItem In objFolder.Items
If olMailItem.TaskCompletedDate = "1/1/4501" Then
GoTo Line1
Else
CompCount = CompCount + 1
End If
Line1:
Next olMailItem
MsgBox "Number of emails in " & strFolder & ": " & (EmailCount - CompCount), , "email count"
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.SetColumns ("ReceivedTime")
' Determine date of each message:
For Each myItem In myItems
dateStr = GetDate(myItem.ReceivedTime)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output counts per day:
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
Dim fso As Object
Dim fo As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set fo = fso.CreateTextFile("[Path]\mail_log.txt")
fo.Write msg
fo.Close
Set fo = Nothing
Set fso = Nothing
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
Function GetDate(dt As Date) As String
GetDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt)
End Function
Whatever I try, I can't get a way to exclude the completed items from the final count that goes to the txt files.
Help?
I found this code elsewhere online and modified it to fit my needs, but I need some help to get the last kink out of it.
For some more info on my needs, I have to check several mailboxes at work for a daily report and this code does everything I need save for one little thing.
As you can see, I exclude all emails marked as "completed." Since these mailboxes are handled by other parties, I'm unable to run rules and move the emails myself. I am only able to count them for my report.
Sub email_count()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer, CompCount As Integer
Dim strFolder As String
Dim olMailItem As Outlook.MailItem
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
CompCount = 0
On Error Resume Next
Set objFolder = Application.GetNamespace("MAPI").Folders("Mailbox Name").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
strFolder = objFolder.Parent
EmailCount = objFolder.Items.Count
For Each olMailItem In objFolder.Items
If olMailItem.TaskCompletedDate = "1/1/4501" Then
GoTo Line1
Else
CompCount = CompCount + 1
End If
Line1:
Next olMailItem
MsgBox "Number of emails in " & strFolder & ": " & (EmailCount - CompCount), , "email count"
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.SetColumns ("ReceivedTime")
' Determine date of each message:
For Each myItem In myItems
dateStr = GetDate(myItem.ReceivedTime)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output counts per day:
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
Dim fso As Object
Dim fo As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set fo = fso.CreateTextFile("[Path]\mail_log.txt")
fo.Write msg
fo.Close
Set fo = Nothing
Set fso = Nothing
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
Function GetDate(dt As Date) As String
GetDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt)
End Function
Whatever I try, I can't get a way to exclude the completed items from the final count that goes to the txt files.
Help?