Reply to thread

Message: [QUOTE="Eric Legault [MVP - Outlook], post: 4865349"] Try using this code as a basis for what you want to do. The Item_Add event will fire when an e-mail is moved to the folder that you specify, and then you can work with the message in any way you want. Keep in mind that the Item_Add event is flaky and may not fire if a large number of messages are moved/copied/delivered to a folder at the same time. '--------------------------------------------------------------------------------------- ' Module : clsMailItemTrapper ' Usage : ' : In the ThisOutlookSession module, you must instantiate this class properly ' : so it will run while Outlook is open ' ' e.g.: ' Dim myTrapper As clsMailItemTrapper ' ' Private Sub Application_Startup() ' Set myTrapper = New clsMailItemTrapper ' End Sub ' Private Sub Application_Quit() ' Set myTrapper = Nothing ' End Su '--------------------------------------------------------------------------------------- Option Explicit Dim WithEvents objMonitoredFolderItems As Outlook.Items Private objMonitoredFolder As Outlook.MAPIFolder Private objNS As Outlook.NameSpace Private Sub Class_Initialize() On Error GoTo EH: Set objNS = Application.GetNamespace("MAPI") 'Method 1: if you know the EntryID for the folder... Set objMonitoredFolder = objNS.GetFolderFromID("000000003F89017490AEDA4098A93E729EC138D402890000") 'Method 2: set to a default folder Set objMonitoredFolder = objNS.GetDefaultFolder(olFolderInbox) 'Method 3: if you know the full path to the folder Set objMonitoredFolder = OpenMAPIFolder("PST Name\RootFolderName\SubFolder") Set objMonitoredFolderItems = objMonitoredFolder.Items EH: If Err.Number <> 0 Then Exit Sub End If End Sub Private Sub Class_Terminate() Set objMonitoredFolder = Nothing Set objMonitoredFolderItems = Nothing Set objNS = Nothing End Sub Private Sub objMonitoredFolderItems_ItemAdd(ByVal Item As Object) On Error GoTo EH: If Item.Class <> olMail Then Exit Sub Dim objMail As Outlook.MailItem Set objMail = Item 'Do something with the message Set objMail = Nothing EH: If Err.Number <> 0 Then Resume Next End If End Sub '****************************************************************************** 'Custom procedure: OpenMAPIFolder(ByVal strPath) 'Purpose: Return a MAPIFolder from Path argument 'Returns: MAPIFolder objec '****************************************************************************** Function OpenMAPIFolder(ByVal strPath) As Outlook.MAPIFolder On Error GoTo OpenMAPIFolder_Error Dim objFldr As Outlook.MAPIFolder Dim strDir As String Dim strName As String Dim i As Integer If strPath = "" Then Exit Function If Left(strPath, Len("\")) = "\" Then strPath = Mid(strPath, Len("\") + 1) Else Set objFldr = ActiveExplorer.CurrentFolder End If While strPath <> "" i = InStr(strPath, "\") If i Then strDir = Left(strPath, i - 1) strPath = Mid(strPath, i + Len("\")) Else strDir = strPath strPath = "" End If If objFldr Is Nothing Then Set objFldr = objNS.Folders(strDir) On Error GoTo 0 Else Set objFldr = objFldr.Folders(strDir) End If Wend Set OpenMAPIFolder = objFldr On Error GoTo 0 Exit Function OpenMAPIFolder_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure OpenMAPIFolder" End Function [/QUOTE]

Verification