![]() |
#1
|
|||
|
|||
![]()
I am trying to write an Outlook program to move mail to a specific folder based on text in the subject, or anything else.
The program can move mail from the Inbox to a subfolder of Inbox, but I can't for the life of me figure out how to make it go to a folder called "Confirmed", which is NOT a subfolder of Inbox. Any help would be greatly appreciated! Here is the source code: Option Explicit Sub Analyze() ' This program will analyze the Outlook Inbox On Error GoTo Analyze_Err ' The NameSpace is the object that gives you access to all of Outlook's Folders. ' In Outlook, there is only one, and it is called "MAPI", which ' is an acronym for Messaging Application Programming Interface. Dim ns As NameSpace Dim CurrentMailItem As MailItem ' We are going to refer to a mail folder (a MAPIFolder object) Dim Inbox As MAPIFolder Dim Item As Object Dim Atmt As Attachment ' The attachment objects we will be looking for Dim FileName As String ' Name and save path for each attachment Dim a As Integer ' Number of attachments found Dim i As Integer ' Number of items in the Inbox Dim m As Integer ' Number of items moved Dim strMsg As String Set ns = GetNamespace("MAPI") Set Inbox = ns.GetDefaultFolder(olFolderInbox) a = 0 ' Init the number of attachments i = 0 ' Init the number of items If Inbox.Items.Count = 0 Then MsgBox "There are no messages in the Inbox.", vbInformation, _ "Nothing Found" Exit Sub End If ' The Inbox does indeed contain something. For Each Item In Inbox.Items i = i + 1 For Each Atmt In Item.Attachments a = a + 1 Next Atmt strMsg = "" If InStr(1, Item.Subject, "SR", vbTextCompare) Then strMsg = strMsg & "This item pertains to an SR." & vbCrLf strMsg = strMsg & "Subject: " & Item.Subject & vbCrLf If MoveMail(Item, Inbox.Folders.Item("Processed").EntryID) Then m = m + 1 strMsg = strMsg & "Item was moved!" & vbCrLf Else strMsg = strMsg & "The message was not moved!" & vbCrLf End If MsgBox strMsg, vbInformation, "Item #" & Str(i) & " Info" End If Next Item strMsg = "I found " & i & " items in your Inbox." & vbCrLf strMsg = strMsg & _ "I moved " & m & " files." & vbCrLf MsgBox strMsg, vbInformation, "Finished!" Analyze_Exit: Set Atmt = Nothing Set Item = Nothing Set ns = Nothing Exit Sub Analyze_Err: MsgBox "An unexpected error has occurred." & vbCrLf & _ "Please note and report the following information." & vbCrLf & _ "Macro name: Analyze" & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Description: " & Err.Description & vbCrLf _ , vbCritical, "Error!" Resume Analyze_Exit Exit Sub End Sub Private Function MoveMail(CurrentMailItem As MailItem, strTargFldrID As String) As Boolean Dim CurrentNameSpace As NameSpace Dim CurrentMoveMailItem As MailItem Set CurrentNameSpace = Application.GetNamespace("MAPI") On Error GoTo FINISH: Set CurrentMoveMailItem = CurrentMailItem.Copy CurrentMoveMailItem.Move _ DestFldr:=CurrentNameSpace.GetFolderFromID(strTarg FldrID) 'CurrMailItem.Delete Err.Number = True FINISH: MoveMail = CBool(Err.Number) End Function |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
Microsoft Licensing | LizzyRut | Office | 0 | 10-14-2008 02:19 PM |
Microsoft calendar 6 | pljames | Misc | 0 | 05-31-2008 05:33 PM |
![]() |
Wiily | Outlook | 1 | 04-14-2006 02:06 AM |
![]() |
MICH | Office | 2 | 11-27-2005 03:36 AM |
![]() |
sufi | Office | 2 | 10-29-2005 07:56 PM |