How to properly reference sub-folder using "WithEvents"?

J

jzeyer

I am currently trying to finish up an Outlook project whereby I increase a
counter for every message that is put into a sub-folder called "Completed"
which exists under the Inbox in Outlook 2002. I am missing some kind of link
between the WithEvents method and the actual subfolder. How do you properly
reference a user-made subfolder with the "WithEvents" method? My current
code is as follows:

Option Explicit
Option Compare Text

'Private WithEvents olInboxItems As Items
Private WithEvents objFolderItems As Items

'Public Function GetFolder(strFolderPath As String) As MAPIFolder

'' folder path needs to be something like
'' "Public Folders\All Public Folders\Company\Sales"
'Dim objApp As Outlook.Application
'Dim objNS As Outlook.NameSpace
'Dim colFolders As Outlook.Folders
'Dim objFolder As Outlook.MAPIFolder
'Dim arrFolders() As String
'Dim I As Long
'On Error Resume Next

'strFolderPath = Replace(strFolderPath, "/", "\")
'arrFolders() = Split(strFolderPath, "\")
'Set objApp = CreateObject("Outlook.Application")
'Set objNS = objApp.GetNamespace("MAPI")
'Set objFolder = objNS.Folders.Item(arrFolders(0))
'If Not objFolder Is Nothing Then
'For I = 1 To UBound(arrFolders)
'Set colFolders = objFolder.Folders
'Set objFolder = Nothing
'Set objFolder = colFolders.Item(arrFolders(I))
'If objFolder Is Nothing Then
'Exit For
'End If
'Next
'End If

'Set GetFolder = objFolder
'Set colFolders = Nothing
'Set objNS = Nothing
'Set objApp = Nothing

'End Function

Private Sub Application_Quit()

' disassociate global objects
Set objFolderItems = Nothing

End Sub


Private Sub objFolderItems_ItemAdd(ByVal Item As Object)
Dim strSubject As String
Dim strSearch As String
Dim varFound As Variant
If Item.Class = olMail Then
strSubject = Item.Subject
strSearch = "undeliverable"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "your mailbox is over"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "out of office autoreply"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "warning"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "delivery status notification"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "failure notice"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "summary of junk email"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
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).Folders("Complete")
Set objMessageCountFolder =
objNS.GetDefaultFolder(olFolderInbox).Folders("Message Count")
'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

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

strNow = FormatDateTime(Now, vbLongDate)
strFind = "[Subject] = """ & strNow & """"

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

Set MyItem = Application.CreateItem(olMailItem)
MyItem.Subject = objNS.CurrentUser & "'s Daily E-Mail Count For " & strNow
MyItem.Body = "Total e-mail's completed for " & strNow & ": " &
objTodayCount.Mileage
MyItem.To = "Jason Zeyer"
MyItem.Send

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

End Sub

Public Sub Application_Startup()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolderItems As MAPIFolder

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolderItems =
objNS.GetDefaultFolder(olFolderInbox).Folders("Complete")
'Set objFolderItems = GetFolder("Outlook Today/Inbox/Complete")

End Sub

Thanks for any help you can lend!
 
E

Eric Legault [MVP - Outlook]

You're setting the wrong object to objFolderItems:

Set objFolderItems = objNS.GetDefaultFolder(olFolderInbox).Folders("Complete")

On that line, you are actually retrieving a MAPIFolder object. Just change
it to this:

Set objFolderItems =
objNS.GetDefaultFolder(olFolderInbox).Folders("Complete").Items

Technically, you should also break that apart into multiple objects:

Set objFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objSubFolder = objFolder.Folders("Complete")
Set objFolderItems = objSubFolder.Items

Also keep in mind that the Item_Add event is not guaranteed to fire if
multiple items are added at once. If you need this guarantee, it is only
possible with an Exchange Event Sink configured on the folder.

--
Eric Legault - B.A, MCP, MCSD, Outlook MVP
Try Picture Attachments Wizard for Outlook! http://tinyurl.com/9bby8
Job: http://www.imaginets.com
Blog: http://blogs.officezealot.com/legault/


jzeyer said:
I am currently trying to finish up an Outlook project whereby I increase a
counter for every message that is put into a sub-folder called "Completed"
which exists under the Inbox in Outlook 2002. I am missing some kind of link
between the WithEvents method and the actual subfolder. How do you properly
reference a user-made subfolder with the "WithEvents" method? My current
code is as follows:

Option Explicit
Option Compare Text

'Private WithEvents olInboxItems As Items
Private WithEvents objFolderItems As Items

'Public Function GetFolder(strFolderPath As String) As MAPIFolder

'' folder path needs to be something like
'' "Public Folders\All Public Folders\Company\Sales"
'Dim objApp As Outlook.Application
'Dim objNS As Outlook.NameSpace
'Dim colFolders As Outlook.Folders
'Dim objFolder As Outlook.MAPIFolder
'Dim arrFolders() As String
'Dim I As Long
'On Error Resume Next

'strFolderPath = Replace(strFolderPath, "/", "\")
'arrFolders() = Split(strFolderPath, "\")
'Set objApp = CreateObject("Outlook.Application")
'Set objNS = objApp.GetNamespace("MAPI")
'Set objFolder = objNS.Folders.Item(arrFolders(0))
'If Not objFolder Is Nothing Then
'For I = 1 To UBound(arrFolders)
'Set colFolders = objFolder.Folders
'Set objFolder = Nothing
'Set objFolder = colFolders.Item(arrFolders(I))
'If objFolder Is Nothing Then
'Exit For
'End If
'Next
'End If

'Set GetFolder = objFolder
'Set colFolders = Nothing
'Set objNS = Nothing
'Set objApp = Nothing

'End Function

Private Sub Application_Quit()

' disassociate global objects
Set objFolderItems = Nothing

End Sub


Private Sub objFolderItems_ItemAdd(ByVal Item As Object)
Dim strSubject As String
Dim strSearch As String
Dim varFound As Variant
If Item.Class = olMail Then
strSubject = Item.Subject
strSearch = "undeliverable"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "your mailbox is over"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "out of office autoreply"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "warning"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "delivery status notification"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "failure notice"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "summary of junk email"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
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).Folders("Complete")
Set objMessageCountFolder =
objNS.GetDefaultFolder(olFolderInbox).Folders("Message Count")
'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

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

strNow = FormatDateTime(Now, vbLongDate)
strFind = "[Subject] = """ & strNow & """"

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

Set MyItem = Application.CreateItem(olMailItem)
MyItem.Subject = objNS.CurrentUser & "'s Daily E-Mail Count For " & strNow
MyItem.Body = "Total e-mail's completed for " & strNow & ": " &
objTodayCount.Mileage
MyItem.To = "Jason Zeyer"
MyItem.Send

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

End Sub

Public Sub Application_Startup()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolderItems As MAPIFolder

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolderItems =
objNS.GetDefaultFolder(olFolderInbox).Folders("Complete")
'Set objFolderItems = GetFolder("Outlook Today/Inbox/Complete")

End Sub

Thanks for any help you can lend!
Click to expand...
 
J

jzeyer

Eric,

Thank you for your help. I did break the statement into parts and made the
changes you indicated. However, I am received a "Type Mismatch Error" when
this code runs. Is this because Complete is a user-created folder?

Thanks,
Jason

Eric Legault said:
You're setting the wrong object to objFolderItems:

Set objFolderItems = objNS.GetDefaultFolder(olFolderInbox).Folders("Complete")

On that line, you are actually retrieving a MAPIFolder object. Just change
it to this:

Set objFolderItems =
objNS.GetDefaultFolder(olFolderInbox).Folders("Complete").Items

Technically, you should also break that apart into multiple objects:

Set objFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objSubFolder = objFolder.Folders("Complete")
Set objFolderItems = objSubFolder.Items

Also keep in mind that the Item_Add event is not guaranteed to fire if
multiple items are added at once. If you need this guarantee, it is only
possible with an Exchange Event Sink configured on the folder.

--
Eric Legault - B.A, MCP, MCSD, Outlook MVP
Try Picture Attachments Wizard for Outlook! http://tinyurl.com/9bby8
Job: http://www.imaginets.com
Blog: http://blogs.officezealot.com/legault/


jzeyer said:
I am currently trying to finish up an Outlook project whereby I increase a
counter for every message that is put into a sub-folder called "Completed"
which exists under the Inbox in Outlook 2002. I am missing some kind of link
between the WithEvents method and the actual subfolder. How do you properly
reference a user-made subfolder with the "WithEvents" method? My current
code is as follows:

Option Explicit
Option Compare Text

'Private WithEvents olInboxItems As Items
Private WithEvents objFolderItems As Items

'Public Function GetFolder(strFolderPath As String) As MAPIFolder

'' folder path needs to be something like
'' "Public Folders\All Public Folders\Company\Sales"
'Dim objApp As Outlook.Application
'Dim objNS As Outlook.NameSpace
'Dim colFolders As Outlook.Folders
'Dim objFolder As Outlook.MAPIFolder
'Dim arrFolders() As String
'Dim I As Long
'On Error Resume Next

'strFolderPath = Replace(strFolderPath, "/", "\")
'arrFolders() = Split(strFolderPath, "\")
'Set objApp = CreateObject("Outlook.Application")
'Set objNS = objApp.GetNamespace("MAPI")
'Set objFolder = objNS.Folders.Item(arrFolders(0))
'If Not objFolder Is Nothing Then
'For I = 1 To UBound(arrFolders)
'Set colFolders = objFolder.Folders
'Set objFolder = Nothing
'Set objFolder = colFolders.Item(arrFolders(I))
'If objFolder Is Nothing Then
'Exit For
'End If
'Next
'End If

'Set GetFolder = objFolder
'Set colFolders = Nothing
'Set objNS = Nothing
'Set objApp = Nothing

'End Function

Private Sub Application_Quit()

' disassociate global objects
Set objFolderItems = Nothing

End Sub


Private Sub objFolderItems_ItemAdd(ByVal Item As Object)
Dim strSubject As String
Dim strSearch As String
Dim varFound As Variant
If Item.Class = olMail Then
strSubject = Item.Subject
strSearch = "undeliverable"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "your mailbox is over"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "out of office autoreply"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "warning"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "delivery status notification"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "failure notice"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "summary of junk email"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
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).Folders("Complete")
Set objMessageCountFolder =
objNS.GetDefaultFolder(olFolderInbox).Folders("Message Count")
'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

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

strNow = FormatDateTime(Now, vbLongDate)
strFind = "[Subject] = """ & strNow & """"

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

Set MyItem = Application.CreateItem(olMailItem)
MyItem.Subject = objNS.CurrentUser & "'s Daily E-Mail Count For " & strNow
MyItem.Body = "Total e-mail's completed for " & strNow & ": " &
objTodayCount.Mileage
MyItem.To = "Jason Zeyer"
MyItem.Send

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

End Sub

Public Sub Application_Startup()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolderItems As MAPIFolder

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolderItems =
objNS.GetDefaultFolder(olFolderInbox).Folders("Complete")
'Set objFolderItems = GetFolder("Outlook Today/Inbox/Complete")

End Sub

Thanks for any help you can lend!
Click to expand...
Click to expand...
 
J

jzeyer

Sorry, Eric. Your suggestion worked as you stated. I inadvertently declared
objFolderItems as MAPIFolder instead of Items. After I made the change and
the code still was not firing, I took a good hard look at the code again and
commented out the line which declared objFolderItems. After I did this, the
code worked great. Being relatively new to Outlook programming, I'm going to
take a guess and say that declaring this object in Application_Startup()
nullifies the WithEvents statement declared previously and this was what was
preventing the code from working. Thanks again!

jzeyer said:
Eric,

Thank you for your help. I did break the statement into parts and made the
changes you indicated. However, I am received a "Type Mismatch Error" when
this code runs. Is this because Complete is a user-created folder?

Thanks,
Jason

Eric Legault said:
You're setting the wrong object to objFolderItems:

Set objFolderItems = objNS.GetDefaultFolder(olFolderInbox).Folders("Complete")

On that line, you are actually retrieving a MAPIFolder object. Just change
it to this:

Set objFolderItems =
objNS.GetDefaultFolder(olFolderInbox).Folders("Complete").Items

Technically, you should also break that apart into multiple objects:

Set objFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objSubFolder = objFolder.Folders("Complete")
Set objFolderItems = objSubFolder.Items

Also keep in mind that the Item_Add event is not guaranteed to fire if
multiple items are added at once. If you need this guarantee, it is only
possible with an Exchange Event Sink configured on the folder.

--
Eric Legault - B.A, MCP, MCSD, Outlook MVP
Try Picture Attachments Wizard for Outlook! http://tinyurl.com/9bby8
Job: http://www.imaginets.com
Blog: http://blogs.officezealot.com/legault/


jzeyer said:
I am currently trying to finish up an Outlook project whereby I increase a
counter for every message that is put into a sub-folder called "Completed"
which exists under the Inbox in Outlook 2002. I am missing some kind of link
between the WithEvents method and the actual subfolder. How do you properly
reference a user-made subfolder with the "WithEvents" method? My current
code is as follows:

Option Explicit
Option Compare Text

'Private WithEvents olInboxItems As Items
Private WithEvents objFolderItems As Items

'Public Function GetFolder(strFolderPath As String) As MAPIFolder

'' folder path needs to be something like
'' "Public Folders\All Public Folders\Company\Sales"
'Dim objApp As Outlook.Application
'Dim objNS As Outlook.NameSpace
'Dim colFolders As Outlook.Folders
'Dim objFolder As Outlook.MAPIFolder
'Dim arrFolders() As String
'Dim I As Long
'On Error Resume Next

'strFolderPath = Replace(strFolderPath, "/", "\")
'arrFolders() = Split(strFolderPath, "\")
'Set objApp = CreateObject("Outlook.Application")
'Set objNS = objApp.GetNamespace("MAPI")
'Set objFolder = objNS.Folders.Item(arrFolders(0))
'If Not objFolder Is Nothing Then
'For I = 1 To UBound(arrFolders)
'Set colFolders = objFolder.Folders
'Set objFolder = Nothing
'Set objFolder = colFolders.Item(arrFolders(I))
'If objFolder Is Nothing Then
'Exit For
'End If
'Next
'End If

'Set GetFolder = objFolder
'Set colFolders = Nothing
'Set objNS = Nothing
'Set objApp = Nothing

'End Function

Private Sub Application_Quit()

' disassociate global objects
Set objFolderItems = Nothing

End Sub


Private Sub objFolderItems_ItemAdd(ByVal Item As Object)
Dim strSubject As String
Dim strSearch As String
Dim varFound As Variant
If Item.Class = olMail Then
strSubject = Item.Subject
strSearch = "undeliverable"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "your mailbox is over"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "out of office autoreply"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "warning"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "delivery status notification"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "failure notice"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
strSearch = "summary of junk email"
varFound = InStr(1, strSubject, strSearch)
If varFound <> 0 Or varFound = Null Then
'MsgBox "This Item Will Not Be Counted", vbOKOnly, "Trip Test
Code"
Exit Sub
End If
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).Folders("Complete")
Set objMessageCountFolder =
objNS.GetDefaultFolder(olFolderInbox).Folders("Message Count")
'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

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

strNow = FormatDateTime(Now, vbLongDate)
strFind = "[Subject] = """ & strNow & """"

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

Set MyItem = Application.CreateItem(olMailItem)
MyItem.Subject = objNS.CurrentUser & "'s Daily E-Mail Count For " & strNow
MyItem.Body = "Total e-mail's completed for " & strNow & ": " &
objTodayCount.Mileage
MyItem.To = "Jason Zeyer"
MyItem.Send

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

End Sub

Public Sub Application_Startup()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolderItems As MAPIFolder

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolderItems =
objNS.GetDefaultFolder(olFolderInbox).Folders("Complete")
'Set objFolderItems = GetFolder("Outlook Today/Inbox/Complete")

End Sub

Thanks for any help you can lend!
Click to expand...
Click to expand...
Click to expand...
 

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

Keeping Count of emails received each day 3
How do I properly use sub-folders of the Inbox with "WithEvents"? 2
Change from Text to Value 1
For Each loop not getting all Email Items 3
import to custom form 6
Set Item.SaveSentMessageFolder = objFolder run time error '424' 13
Copying contents from one field to another field 6
copying a custom view from a public folder and distributing programatically 1

Top