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
 
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
Click to expand...
 
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?
Click to expand...
VBA in "This Outlook Session"
Click to expand...
Option Explicit
Click to expand...
Private WithEvents olInboxItems As Items
Click to expand...
Private Sub Application_Startup()
Dim objNS As NameSpace
Click to expand...
Set objNS = Application.GetNamespace("MAPI")
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
Click to expand...
Set objNS = Nothing
End Sub
Click to expand...
Private Sub Application_Quit()
'disassociate global objects
Set olInboxItems = Nothing
End Sub
Click to expand...
Private Sub olInboxItems_Itemsadd(ByVal Item As Object)
If Item.Class = olMail Then
Call UpdateCounter
End If
End Sub
Click to expand...
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
Click to expand...
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objMessageCountFolder = objInbox.Folders("Message Count")
Click to expand...
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
Click to expand...
End If
Click to expand...
Set objTodayCount = Nothing
Set objMessageCountFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub
Click to expand...
VBA in Module
Click to expand...
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
Click to expand...
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objMessageCountFolder = objInbox.Folders("Message Count")
Click to expand...
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
Click to expand...
End If
Click to expand...
Set objTodayCount = Nothing
Set objMessageCountFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub- Hide quoted text -
Click to expand...

- Show quoted text -
Click to expand...

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.
Click to expand...
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?
Click to expand...
VBA in "This Outlook Session"
Click to expand...
Option Explicit
Click to expand...
Private WithEvents olInboxItems As Items
Click to expand...
Private Sub Application_Startup()
Dim objNS As NameSpace
Click to expand...
Set objNS = Application.GetNamespace("MAPI")
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
Click to expand...
Set objNS = Nothing
End Sub
Click to expand...
Private Sub Application_Quit()
'disassociate global objects
Set olInboxItems = Nothing
End Sub
Click to expand...
Private Sub olInboxItems_Itemsadd(ByVal Item As Object)
If Item.Class = olMail Then
Call UpdateCounter
End If
End Sub
Click to expand...
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
Click to expand...
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objMessageCountFolder = objInbox.Folders("Message Count")
Click to expand...
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
Click to expand...
End If
Click to expand...
Set objTodayCount = Nothing
Set objMessageCountFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub
Click to expand...
VBA in Module
Click to expand...
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
Click to expand...
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objMessageCountFolder = objInbox.Folders("Message Count")
Click to expand...
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
Click to expand...
End If
Click to expand...
Set objTodayCount = Nothing
Set objMessageCountFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub- Hide quoted text -
Click to expand...

- Show quoted text -
Click to expand...

I have restarted Outlook, and PC with no avail. Not sure what you
mean by running Application_Startup manually. How do I do that?
Click to expand...
 
C

Coucal

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

Similar Threads

How to properly reference sub-folder using "WithEvents"? 3
How do I properly use sub-folders of the Inbox with "WithEvents"? 2
Set Item.SaveSentMessageFolder = objFolder run time error '424' 13
Move Email in an IMAP Account 0
forcing a rule when opening outlook via code 1
How do I identify if it's a meeting request in this outlook macro? 1
Moving Calendar items to a folder 1
Outlook Outlook macros not working until VBA editor is opened 4

Top