Keeping Count of emails received each day


M

Murphybp2

I am trying to implement a solution created by Sue Mosher on how to
keep a count of the number of emails that I get on a daily basis. I
have gotten this to work on my Outlook at home, but can't seem to get
it to work at the office. I'm using Outlook 2003. Here is the code
that I've Used. I can manually run the UpdateCounter VBA, and it
creates the record, but I can't get it to work when mail is actually
received. Anyone have any suggestions on what I need to do?

VBA in "This Outlook Session"

Option Explicit

Private WithEvents olInboxItems As Items

Private Sub Application_Startup()
Dim objNS As NameSpace

Set objNS = Application.GetNamespace("MAPI")
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items

Set objNS = Nothing
End Sub

Private Sub Application_Quit()
'disassociate global objects
Set olInboxItems = Nothing
End Sub

Private Sub olInboxItems_Itemsadd(ByVal Item As Object)
If Item.Class = olMail Then
Call UpdateCounter
End If
End Sub

Sub UpdateCounter()
Dim objApp As Application
Dim objNS As NameSpace
Dim objInbox As MAPIFolder
Dim objMessageCountFolder As MAPIFolder
Dim objTodayCount As PostItem
Dim strNow As String
Dim strFind As String

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objMessageCountFolder = objInbox.Folders("Message Count")

If Not objMessageCountFolder Is Nothing Then
' get the item that matches today
strNow = FormatDateTime(Now, vbLongDate)
strFind = "[Subject] = """ & strNow & """"
Set objTodayCount = objMessageCountFolder.Items.Find(strFind)
If objTodayCount Is Nothing Then
' create a new item
Set objTodayCount = _
objMessageCountFolder.Items.Add("IPM.Post")
objTodayCount.Subject = strNow
objTodayCount.Mileage = 1
Else
objTodayCount.Mileage = CInt(objTodayCount.Mileage) + 1
End If
objTodayCount.Save

End If

Set objTodayCount = Nothing
Set objMessageCountFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub

VBA in Module

Sub UpdateCounter()
Dim objApp As Application
Dim objNS As NameSpace
Dim objInbox As MAPIFolder
Dim objMessageCountFolder As MAPIFolder
Dim objTodayCount As PostItem
Dim strNow As String
Dim strFind As String

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objMessageCountFolder = objInbox.Folders("Message Count")

If Not objMessageCountFolder Is Nothing Then
' get the item that matches today
strNow = FormatDateTime(Now, vbLongDate)
strFind = "[Subject] = """ & strNow & """"
Set objTodayCount = objMessageCountFolder.Items.Find(strFind)
If objTodayCount Is Nothing Then
' create a new item
Set objTodayCount = _
objMessageCountFolder.Items.Add("IPM.Post")
objTodayCount.Subject = strNow
objTodayCount.Mileage = 1
Else
objTodayCount.Mileage = CInt(objTodayCount.Mileage) + 1
End If
objTodayCount.Save

End If

Set objTodayCount = Nothing
Set objMessageCountFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub
 
Ad

Advertisements

M

Michael Bauer [MVP - Outlook]

If it runs manually then it should do so automatically, too. Please note,
after code changes you need to restart Outlook or run Application_Startup
manually.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
Organize eMails:
<http://www.vboffice.net/product.html?id=2006063&cmd=detail&lang=en&pub=6>


Am Thu, 23 Aug 2007 15:45:43 -0000 schrieb Murphybp2:
I am trying to implement a solution created by Sue Mosher on how to
keep a count of the number of emails that I get on a daily basis. I
have gotten this to work on my Outlook at home, but can't seem to get
it to work at the office. I'm using Outlook 2003. Here is the code
that I've Used. I can manually run the UpdateCounter VBA, and it
creates the record, but I can't get it to work when mail is actually
received. Anyone have any suggestions on what I need to do?

VBA in "This Outlook Session"

Option Explicit

Private WithEvents olInboxItems As Items

Private Sub Application_Startup()
Dim objNS As NameSpace

Set objNS = Application.GetNamespace("MAPI")
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items

Set objNS = Nothing
End Sub

Private Sub Application_Quit()
'disassociate global objects
Set olInboxItems = Nothing
End Sub

Private Sub olInboxItems_Itemsadd(ByVal Item As Object)
If Item.Class = olMail Then
Call UpdateCounter
End If
End Sub

Sub UpdateCounter()
Dim objApp As Application
Dim objNS As NameSpace
Dim objInbox As MAPIFolder
Dim objMessageCountFolder As MAPIFolder
Dim objTodayCount As PostItem
Dim strNow As String
Dim strFind As String

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objMessageCountFolder = objInbox.Folders("Message Count")

If Not objMessageCountFolder Is Nothing Then
' get the item that matches today
strNow = FormatDateTime(Now, vbLongDate)
strFind = "[Subject] = """ & strNow & """"
Set objTodayCount = objMessageCountFolder.Items.Find(strFind)
If objTodayCount Is Nothing Then
' create a new item
Set objTodayCount = _
objMessageCountFolder.Items.Add("IPM.Post")
objTodayCount.Subject = strNow
objTodayCount.Mileage = 1
Else
objTodayCount.Mileage = CInt(objTodayCount.Mileage) + 1
End If
objTodayCount.Save

End If

Set objTodayCount = Nothing
Set objMessageCountFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub

VBA in Module

Sub UpdateCounter()
Dim objApp As Application
Dim objNS As NameSpace
Dim objInbox As MAPIFolder
Dim objMessageCountFolder As MAPIFolder
Dim objTodayCount As PostItem
Dim strNow As String
Dim strFind As String

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objMessageCountFolder = objInbox.Folders("Message Count")

If Not objMessageCountFolder Is Nothing Then
' get the item that matches today
strNow = FormatDateTime(Now, vbLongDate)
strFind = "[Subject] = """ & strNow & """"
Set objTodayCount = objMessageCountFolder.Items.Find(strFind)
If objTodayCount Is Nothing Then
' create a new item
Set objTodayCount = _
objMessageCountFolder.Items.Add("IPM.Post")
objTodayCount.Subject = strNow
objTodayCount.Mileage = 1
Else
objTodayCount.Mileage = CInt(objTodayCount.Mileage) + 1
End If
objTodayCount.Save

End If

Set objTodayCount = Nothing
Set objMessageCountFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub
 
M

Murphybp2

If it runs manually then it should do so automatically, too. Please note,
after code changes you need to restart Outlook or run Application_Startup
manually.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
Organize eMails:
<http://www.vboffice.net/product.html?id=2006063&cmd=detail&lang=en&pub=6>

Am Thu, 23 Aug 2007 15:45:43 -0000 schrieb Murphybp2:


I am trying to implement a solution created by Sue Mosher on how to
keep a count of the number of emails that I get on a daily basis. I
have gotten this to work on my Outlook at home, but can't seem to get
it to work at the office. I'm using Outlook 2003. Here is the code
that I've Used. I can manually run the UpdateCounter VBA, and it
creates the record, but I can't get it to work when mail is actually
received. Anyone have any suggestions on what I need to do?
VBA in "This Outlook Session"
Option Explicit
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.GetNamespace("MAPI")
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
Set objNS = Nothing
End Sub
Private Sub Application_Quit()
'disassociate global objects
Set olInboxItems = Nothing
End Sub
Private Sub olInboxItems_Itemsadd(ByVal Item As Object)
If Item.Class = olMail Then
Call UpdateCounter
End If
End Sub
Sub UpdateCounter()
Dim objApp As Application
Dim objNS As NameSpace
Dim objInbox As MAPIFolder
Dim objMessageCountFolder As MAPIFolder
Dim objTodayCount As PostItem
Dim strNow As String
Dim strFind As String
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objMessageCountFolder = objInbox.Folders("Message Count")
If Not objMessageCountFolder Is Nothing Then
' get the item that matches today
strNow = FormatDateTime(Now, vbLongDate)
strFind = "[Subject] = """ & strNow & """"
Set objTodayCount = objMessageCountFolder.Items.Find(strFind)
If objTodayCount Is Nothing Then
' create a new item
Set objTodayCount = _
objMessageCountFolder.Items.Add("IPM.Post")
objTodayCount.Subject = strNow
objTodayCount.Mileage = 1
Else
objTodayCount.Mileage = CInt(objTodayCount.Mileage) + 1
End If
objTodayCount.Save
Set objTodayCount = Nothing
Set objMessageCountFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub
VBA in Module
Sub UpdateCounter()
Dim objApp As Application
Dim objNS As NameSpace
Dim objInbox As MAPIFolder
Dim objMessageCountFolder As MAPIFolder
Dim objTodayCount As PostItem
Dim strNow As String
Dim strFind As String
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objMessageCountFolder = objInbox.Folders("Message Count")
If Not objMessageCountFolder Is Nothing Then
' get the item that matches today
strNow = FormatDateTime(Now, vbLongDate)
strFind = "[Subject] = """ & strNow & """"
Set objTodayCount = objMessageCountFolder.Items.Find(strFind)
If objTodayCount Is Nothing Then
' create a new item
Set objTodayCount = _
objMessageCountFolder.Items.Add("IPM.Post")
objTodayCount.Subject = strNow
objTodayCount.Mileage = 1
Else
objTodayCount.Mileage = CInt(objTodayCount.Mileage) + 1
End If
objTodayCount.Save
Set objTodayCount = Nothing
Set objMessageCountFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub- Hide quoted text -
- Show quoted text -
I have restarted Outlook, and PC with no avail. Not sure what you
mean by running Application_Startup manually. How do I do that?
 
M

Michael Bauer [MVP - Outlook]

Place the cursor into the procedure and press F5.

Creating another instance of Outlook within Outlook is evil. So delete these
two lines:

Dim objApp As Application
Set objApp = CreateObject("Outlook.Application")

and replace all remaining objApp in your code by Application.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
Organize eMails:
<http://www.vboffice.net/product.html?id=2006063&cmd=detail&lang=en&pub=6>


Am Wed, 29 Aug 2007 16:55:35 -0000 schrieb Murphybp2:
If it runs manually then it should do so automatically, too. Please note,
after code changes you need to restart Outlook or run Application_Startup
manually.
Am Thu, 23 Aug 2007 15:45:43 -0000 schrieb Murphybp2:


I am trying to implement a solution created by Sue Mosher on how to
keep a count of the number of emails that I get on a daily basis. I
have gotten this to work on my Outlook at home, but can't seem to get
it to work at the office. I'm using Outlook 2003. Here is the code
that I've Used. I can manually run the UpdateCounter VBA, and it
creates the record, but I can't get it to work when mail is actually
received. Anyone have any suggestions on what I need to do?
VBA in "This Outlook Session"
Option Explicit
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.GetNamespace("MAPI")
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
Set objNS = Nothing
End Sub
Private Sub Application_Quit()
'disassociate global objects
Set olInboxItems = Nothing
End Sub
Private Sub olInboxItems_Itemsadd(ByVal Item As Object)
If Item.Class = olMail Then
Call UpdateCounter
End If
End Sub
Sub UpdateCounter()
Dim objApp As Application
Dim objNS As NameSpace
Dim objInbox As MAPIFolder
Dim objMessageCountFolder As MAPIFolder
Dim objTodayCount As PostItem
Dim strNow As String
Dim strFind As String
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objMessageCountFolder = objInbox.Folders("Message Count")
If Not objMessageCountFolder Is Nothing Then
' get the item that matches today
strNow = FormatDateTime(Now, vbLongDate)
strFind = "[Subject] = """ & strNow & """"
Set objTodayCount = objMessageCountFolder.Items.Find(strFind)
If objTodayCount Is Nothing Then
' create a new item
Set objTodayCount = _
objMessageCountFolder.Items.Add("IPM.Post")
objTodayCount.Subject = strNow
objTodayCount.Mileage = 1
Else
objTodayCount.Mileage = CInt(objTodayCount.Mileage) + 1
End If
objTodayCount.Save
Set objTodayCount = Nothing
Set objMessageCountFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub
VBA in Module
Sub UpdateCounter()
Dim objApp As Application
Dim objNS As NameSpace
Dim objInbox As MAPIFolder
Dim objMessageCountFolder As MAPIFolder
Dim objTodayCount As PostItem
Dim strNow As String
Dim strFind As String
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objMessageCountFolder = objInbox.Folders("Message Count")
If Not objMessageCountFolder Is Nothing Then
' get the item that matches today
strNow = FormatDateTime(Now, vbLongDate)
strFind = "[Subject] = """ & strNow & """"
Set objTodayCount = objMessageCountFolder.Items.Find(strFind)
If objTodayCount Is Nothing Then
' create a new item
Set objTodayCount = _
objMessageCountFolder.Items.Add("IPM.Post")
objTodayCount.Subject = strNow
objTodayCount.Mileage = 1
Else
objTodayCount.Mileage = CInt(objTodayCount.Mileage) + 1
End If
objTodayCount.Save
Set objTodayCount = Nothing
Set objMessageCountFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub- Hide quoted text -
- Show quoted text -
I have restarted Outlook, and PC with no avail. Not sure what you
mean by running Application_Startup manually. How do I do that?
 
Ad

Advertisements

Joined
Nov 23, 2011
Messages
1
Reaction score
0
Just for record : there is a typo in this useful code :
Private Sub olInboxItems_Itemsadd(ByVal Item As Object) should be :
Private Sub olInboxItems_Itemadd(ByVal Item As Object)

Hope this helps
Alain
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top