Microsoft Outlook Movemail
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
|