How do I properly use sub-folders of the Inbox with "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!
 
S

Sue Mosher [MVP-Outlook]

The technique is the same regardless of the location of the folder:

1) You declare an Items variable WithEvents

2) You instantiate that variable in some code procedure. To get a non-default folder, you need to walk the folder hierarchy using the Folders collections or use a function like GetFolder() below that does that for you.

It looks to me like you have both, since you have this statement in Application_Startup:

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

But you do have two declarations for objFolderItems. Remove the one in Application_Startup.

FYI, there is a newsgroup specifically for general Outlook programming issues "down the hall" at microsoft.public.outlook.program_vba or, via web interface, at http://www.microsoft.com/office/community/en-us/default.mspx?dg=microsoft.public.outlook.program_vba

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



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 objFolderItems As Items

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")

End Sub
Click to expand...
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
Click to expand...
 
J

jzeyer

Sue,

Thank you for replying. I actually discovered this mistake Thursday by
doing a close compare with code from your site. I can't believe the problem
was that easy! I also just received your book on Friday and I am eager to
get reading. Thanks again for your help.

Sue Mosher said:
The technique is the same regardless of the location of the folder:

1) You declare an Items variable WithEvents

2) You instantiate that variable in some code procedure. To get a non-default folder, you need to walk the folder hierarchy using the Folders collections or use a function like GetFolder() below that does that for you.

It looks to me like you have both, since you have this statement in Application_Startup:

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

But you do have two declarations for objFolderItems. Remove the one in Application_Startup.

FYI, there is a newsgroup specifically for general Outlook programming issues "down the hall" at microsoft.public.outlook.program_vba or, via web interface, at http://www.microsoft.com/office/community/en-us/default.mspx?dg=microsoft.public.outlook.program_vba

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



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 objFolderItems As Items

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")

End Sub
Click to expand...
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
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

How to properly reference sub-folder using "WithEvents"? 3
Keeping Count of emails received each day 3
<Sue Mosher> VB Code Modification 3
For Each loop not getting all Email Items 3
Set Item.SaveSentMessageFolder = objFolder run time error '424' 13
import to custom form 6
Copying contents from one field to another field 6
How do I eliminate the "Enable Macro" selection? 16

Top