VB and VBA Users Source Code: Automatically move mail in Outlook 2000
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Automatically move mail in Outlook 2000
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Tuesday, February 20, 2001
Hits:
974
Category:
Internet/Remote Comms
Article:
The following class module is designed to demonstrate how to automatically move new Outlook mail around from folder to folder. A demonstration routine can be found at the bottom of this post. 'If running this project outside of Outlook, please add a reference to 'the Microsoft Outlook 9.0 Office Library Option Explicit Option Compare Text Private WithEvents oOutlookApp As Outlook.Application Private oNameSpace As Outlook.NameSpace, oInBox As Outlook.MAPIFolder, oMoveToFolder As Outlook.MAPIFolder Private zsMoveToFolder As String, zsMoveMailSentTo As String, zbMarkAsRead As Boolean Private Const csNameSeperator As String = ";" 'Purpose : Moves mail items to a specified outlook mailbox 'Inputs : [bCheckMailBox] If True checks all the mail in the inbox and ' moves those sent to the specified name 'Outputs : N/A 'Author : Andrew Baker 'Date : 11/09/2000 'Notes : 'Revisions : Private Sub MoveNewMail(Optional bCheckMailBox As Boolean) Dim oMailItem As Outlook.MailItem Dim bMoveMail As Boolean, lPos As Long, lLenMoveMailSentTo As Long Dim lUnReadCount As Long, lCheckedMailCount As Long Dim lPosOld As Long, sThisName As String On Error GoTo ErrFailed lLenMoveMailSentTo = Len(zsMoveMailSentTo) lUnReadCount = oInBox.UnReadItemCount If lUnReadCount > 0 Or bCheckMailBox = True Then 'Loop over all mail in mail box For Each oMailItem In oInBox.Items If oMailItem.UnRead Or bCheckMailBox Then lPosOld = 0 lCheckedMailCount = lCheckedMailCount + 1 bMoveMail = False If lLenMoveMailSentTo Then 'Only move mail items sent to a specified name lPos = InStr(lPosOld + 1, zsMoveMailSentTo, csNameSeperator) Do While (lPos > 0 And (bMoveMail = False And lPos > 0)) 'Check sent to/cc names sThisName = Mid$(zsMoveMailSentTo, lPosOld + 1, lPos - (lPosOld + 1)) If InStr(1, oMailItem.CC, sThisName) Then bMoveMail = True ElseIf InStr(1, oMailItem.To, sThisName) Then bMoveMail = True Else lPosOld = lPos lPos = InStr(lPosOld + 1, zsMoveMailSentTo, csNameSeperator) End If Loop Else 'Move all new mail to specified folder bMoveMail = True End If If bMoveMail Then 'Move mail item If oMailItem.UnRead Then oMailItem.UnRead = Not zbMarkAsRead End If oMailItem.Move oMoveToFolder End If If lCheckedMailCount = lUnReadCount And bCheckMailBox = False Then 'Checked all new unread mail Exit For End If End If Next End If Exit Sub ErrFailed: MsgBox "Failed to move mail item..." & vbNewLine & _ Err.Description, vbCritical End Sub 'Purpose : The path to the folder to move the mail new items to 'Inputs : Value The folder name. eg. "Personal Folders\Junk Mail\" 'Outputs : N/A 'Author : Andrew Baker 'Date : 11/09/2000 'Notes : 'Revisions : Property Get MoveToFolder() As String MoveToFolder = zsMoveToFolder End Property Property Let MoveToFolder(Value As String) Dim lPos As Long, sThisFolder As String, lPosOldPos As Long On Error GoTo ErrFailed 'Standardise folder variable zsMoveToFolder = Value If Right$(zsMoveToFolder, 1) <> "\" Then zsMoveToFolder = zsMoveToFolder & "\" End If If Left$(zsMoveToFolder, 1) <> "\" Then zsMoveToFolder = "\" & zsMoveToFolder End If lPosOldPos = 2 Set oMoveToFolder = Nothing Do lPos = InStr(lPosOldPos, zsMoveToFolder, "\") If lPos Then sThisFolder = Mid$(zsMoveToFolder, lPosOldPos, lPos - lPosOldPos) If oMoveToFolder Is Nothing Then 'Get main folder Set oMoveToFolder = oNameSpace.Folders(sThisFolder) Else 'Get sub folder Set oMoveToFolder = oMoveToFolder.Folders(sThisFolder) End If Else Exit Do End If lPosOldPos = lPos + 1 Loop While lPos Exit Property ErrFailed: MsgBox "Failed to locate folder " & Value & vbNewLine & _ Err.Description zsMoveToFolder = "" End Property 'If set will only move any new mail items sent to the specified name Property Get MoveMailSentTo() As String MoveMailSentTo = zsMoveMailSentTo End Property 'Deliminated list of names Property Let MoveMailSentTo(Value As String) zsMoveMailSentTo = Value If Right$(zsMoveMailSentTo, 1) <> csNameSeperator Then zsMoveMailSentTo = zsMoveMailSentTo & csNameSeperator End If End Property 'If True marks the new mail as being read before moving it. Property Let MarkAsRead(Value As Boolean) zbMarkAsRead = Value End Property Property Get MarkAsRead() As Boolean MarkAsRead = zbMarkAsRead End Property Private Sub Class_Initialize() Set oOutlookApp = New Outlook.Application Set oNameSpace = oOutlookApp.GetNamespace("MAPI") Set oInBox = oNameSpace.GetDefaultFolder(olFolderInbox) End Sub Private Sub Class_Terminate() Set oMoveToFolder = Nothing Set oInBox = Nothing Set oNameSpace = Nothing Set oOutlookApp = Nothing End Sub 'Manual method of checking the inbox. 'Useful if when creating the class there are 'already new mail items in the inbox Sub Refresh(Optional bCheckMailBox As Boolean = False) If Len(zsMoveToFolder) > 0 And Len(zsMoveMailSentTo) > 0 Then MoveNewMail bCheckMailBox End If End Sub Private Sub oOutlookApp_NewMail() 'Event fired when new mail is received If Len(zsMoveToFolder) > 0 And Len(zsMoveMailSentTo) > 0 Then MoveNewMail End If End Sub PLACE FOLLOWING CODE IN A STANDARD MODULE Private oMoveAdminMail As clsMoveMail 'This routine moves mail sent to "admin" to a 'folder called "\Personal Folders\admin\" Sub MoveMailDemo() Set oMoveAdminMail= New clsMoveMail oMoveAdminMail.MoveMailSentTo = "admin" oMoveAdminMail.MoveToFolder = "\Personal Folders\admin\" oMoveAdminMail.MarkAsRead = True oMoveAdminMail.Refresh 'Force class to check any new mail End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
