Macro to Move Mail Messages from Draft folder to other folders



HELP...Please...I am so a newby on the VB stuff.

I am trying to create a macro that will move messages from my Drafts folder
to another folder, based on specific words in the subject line.

For example: In my drafts file, a message with "HEALTH:" would be moved to
a unique folder called "Health Articles".

I would like the macro to run either as i save items intot the draft folder,
or is there a way to also create a menu "button" to run the macro

Thanks for the help!

Michael Bauer

Am Thu, 8 Jun 2006 12:01:02 -0700 schrieb VBnovice:

For to start the code you can use the ItemAdd event of the Drafts folder. A
sample is available in the VBA help.

In that event check the Item´s Subject property with Instr. If it contains
what you´re looking for then call its Move function, which is also explained
in the help.


Michael - thanks for the start...but even that is above my head! I trided to
use the code provided from another post and modify it. Not my strong point.
Are there sources where i can just get an "add-in" or is there a source where
someone has already written the code that i can just copy and paste? I cant
imagine that i am doing somehting so unique - but i never know.

Any direction to a source where this is already done would be appreciated.
I just dont have the time right now to learn VBA...

Michael Bauer

Am Fri, 9 Jun 2006 04:49:01 -0700 schrieb VBnovice:

A good source for Add-ins is

If you google for "ItemAdd" in an Outlook programming newsgroup (e.g. this
one) there´re tons of samples.


Your original post item said that you would like to move messages from your
drafts folder, either:
(1) as you save them to the drafts folder; or
(2) by using a macro assigned to a menu.

This reply addresses the second part of your question.

The simple answer, as you no doubt guessed, is "yes" - you can create a
macro and assign it to a menu or a custom toolbar button.

However, you said your Drafts folder contained "messages". I'm not sure if
you mean "Mail Items" or "Post Items". As you may know, "Mail Items" are
emails you create to send to other people. "Post Items" are things you
create to store in a folder. If your intention is simply to store items in
a folder, perhaps it would be easier to open the topic folder and create a
Post Item in that folder. To do this, select the topic folder, then open
the File menu, and select New, Post in this Folder). On the other hand, it
may well be, as you say, that you need to store draft emails in a
categorised set of subfolders.

The macro below will move Mail Items or Post Items from the Drafts folder to
a set of subfolders.

To run the macro, it would be sensible to create a custom toolbar. Create a
custom button on the toolbar. Assign the public subprocedure below to the
custom button. If you need help with that, then post again to the

Here's the macro. I hope it will fit into this one post (if not I'll post a
second installment).

Create a new standard module and paste all the macro code below into the
module. (NB your original post is at the end.)

Read the notes (lines beginning with an apostrophe) to get some clues about
what's going on.

I hope you get time to study VBA in future. It's great fun!
Good luck

Public Sub MoveItemsFromDraftsFolder()

' This subprocedure moves Mail or Post Items
' from the Drafts folder to Topic Subfolders.
' A Mail or Post Item is only moved if a
' predefined topic is found in the Item's
' subject.
' This subprocedure will create the Topic
' Subfolder if it does not exist (eg a folder
' for "Health Articles").

' The topic subfolder will be created in an
' "Articles" folder. The "Articles" folder will
' be the parent folder of the Topic Subfolders.
' The "Articles" folder will be created if it
' does not exist.
' The "Articles" folder will reside in the
' "Personal Folders" folder (ie in
' "Outlook Today - Personal Folders").

' Declare a string constant for each topic that
' may appear in the subject line and declare a
' corresponding string constant for the name of
' the folder where the Mail or Post Item should
' be moved to.

Const STRC_TOPIC1 As String = "HEALTH"
Const STRC_FOLDER1 As String = "Health Articles"

Const STRC_FOLDER2 As String = "Sanitation Articles"

Const STRC_FOLDER3 As String = "Radiology Articles"

' Add further constants here for each topic and
' its corresponding Topic Subfolder.

' Declare object variables:
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objDRAFTS_FLDR As Outlook.MAPIFolder
Dim objROOT_FLDR As Outlook.MAPIFolder
Dim objSUB_FLDR As Outlook.MAPIFolder
Dim objO As Object

' Declare other variables:
Dim intRetVal As Integer
Dim blnFolderExists As Boolean
Dim blnRetVal As Boolean
Dim strMessage As String
Dim intButtons As Integer
Dim strHeading As String
Dim intMovedItemsCount As Integer

' Set up an error-handling routine:
On Error GoTo ErrorHandler

' Show message to user to confirm start:
strMessage = "Move Mail or Post Items in Drafts folder to topic
intButtons = vbYesNo + vbQuestion + vbDefaultButton2
strHeading = "Confirm Start" & Space(50)
intRetVal = MsgBox(strMessage, intButtons, strHeading)
If intRetVal <> vbYes Then
strMessage = "Cancelled at your request."
intButtons = vbOKOnly + vbInformation
strHeading = "Finished" & Space(50)
MsgBox strMessage, intButtons, strHeading
GoTo Bye
End If

' Create instances of objects:
Set objOL = New Outlook.Application
Set objNS = objOL.GetNamespace("MAPI")

' Point to the drafts folder:
Set objDRAFTS_FLDR = objNS.GetDefaultFolder(olFolderDrafts)

' Point to the "Outlook Today - Personal Folders" folder:
Set objROOT_FLDR = objNS.Folders("Personal Folders")

' Point to the "Articles" subfolder:
Set objSUB_FLDR = GetMyFolder("Articles", objROOT_FLDR)

' Process each Mail or Post Item object
' in the drafts folder:
For Each objO In objDRAFTS_FLDR.Items
GoSub MoveNextItem

' Show finished message:
If intMovedItemsCount = 1 Then
strMessage = "1 item was moved."
strMessage = CStr(intMovedItemsCount) & " item(s) were moved."
End If
intButtons = vbOKOnly + vbInformation
strHeading = "Information" & Space(20)
MsgBox strMessage, intButtons, strHeading


' Destroy object variables:
GoSub CleanUp

' Exit subprocedure here:
Exit Sub


Set objO = Nothing
Set objSUB_FLDR = Nothing
Set objROOT_FLDR = Nothing
Set objDRAFTS_FLDR = Nothing
Set objNS = Nothing
Set objOL = Nothing


' Call the "MoveIfFound" function for each
' topic in turn. Pass four arguments to the
' function so it can do its work:
' 1. The Mail or Post Item.
' 2. The topic to search for (eg "HEALTH").
' 3. The topic folder's parent folder
' (eg "Articles")
' 4. The name of the topic subfolder
' (eg "Health Articles").
' The "MoveIfFound" function returns TRUE or FALSE.
' Capture this Boolean value in the variable blnRetVal.
' If blnRetVal is TRUE, then the function moved
' the item, so increment the count of the number
' of moved items and return to the FOR-NEXT loop.

' Reset return value before each item
' is processed:
blnRetVal = False

' Check for first topic:
blnRetVal = MoveIfFound(objO, STRC_TOPIC1, objSUB_FLDR, STRC_FOLDER1)
If blnRetVal = True Then
intMovedItemsCount = intMovedItemsCount + 1
End If

' Check for second topic:
blnRetVal = MoveIfFound(objO, STRC_TOPIC2, objSUB_FLDR, STRC_FOLDER2)
If blnRetVal = True Then
intMovedItemsCount = intMovedItemsCount + 1
End If

' Check for third topic:
blnRetVal = MoveIfFound(objO, STRC_TOPIC3, objSUB_FLDR, STRC_FOLDER3)
If blnRetVal = True Then
intMovedItemsCount = intMovedItemsCount + 1
End If

' If any more topics are to be checked, then
' ensure appropriate constants are declared at
' the top of this subprocedure and call the
' "MoveIfFound" function here, passing to it
' the appropriate arguments, eg:
' blnRetVal = MoveIfFound(objO, STRC_TOPIC4, objSUB_FLDR,
' If blnRetVal Then Return



MsgBox "Error No: " & CStr(Err.Number) _
& vbNewLine & vbNewLine _
& Err.Description, vbOKOnly + vbExclamation, "Error"
Resume Bye

End Sub

Private Function GetMyFolder( _
strSubFolderName As String, _
objPARENT_FLDR As Outlook.MAPIFolder) As Outlook.MAPIFolder

' This function checks to see if a subfolder
' exists within a folder. If the subfolder exists,
' then this function returns a reference to the
' subfolder. If the subfolder does not exist,
' then this function creates the subfolder and
' returns a reference to the subfolder.
' IN:
' strSubFolderName:
' The name of the subfolder.
' The folder in which the subfolder needs
' to exist.

Dim objSUBFLDR As Outlook.MAPIFolder
Dim blnSubFolderExists As Boolean

' Assume subfolder does not exist:
blnSubFolderExists = False

' Iterate through the Folders collection of
' the parent folder to see if subfolder exists:
For Each objSUBFLDR In objPARENT_FLDR.Folders
If objSUBFLDR.Name = strSubFolderName Then
blnSubFolderExists = True
Exit For
End If

' If subfolder does not exist, then create it:
If blnSubFolderExists = False Then
Set objSUBFLDR = objPARENT_FLDR.Folders.Add(strSubFolderName)
End If


' Set this function's return value:
Set GetMyFolder = objSUBFLDR

' Destroy object variable:
GoSub CleanUp

Exit Function


Set objSUBFLDR = Nothing

End Function

Private Function MoveIfFound( _
objITEM As Object, _
strTopicToFind As String, _
objPARENT_FLDR As Outlook.MAPIFolder, _
strTopic_Fldr_Name As String) As Boolean

' This function moves a Mail or Post Item
' to a topic subfolder if the item's subject
' contains the topic.
' IN:
' objITEM:
' The Mail or Post Item to be moved
' if the topic is found in the subject.
' strTopicToFind:
' The topic (eg "HEALTH") to find in
' the item's subject.
' The folder that contains the topic
' subfolder.
' strTopic_Fldr_Name:
' The name of the topic folder,
' (eg "Health Articles").
' TRUE if the item is moved.
' FALSE if the item is not moved.

' Declare object variables:
Dim objTOPIC_FLDR As Outlook.MAPIFolder

' Declare other variables:
Dim RetVal As Boolean
Dim strSubject As String
Dim lngTopicFoundAtChar As Long
Dim blnTopicFolderExists As Boolean

' Store function's default return value:
RetVal = False

' Only proceed if the incoming object
' is a Mail Item or a Post Item:
On Error Resume Next
If objITEM.Class = olMail Then GoTo CheckSubject
If objITEM.Class = olPost Then GoTo CheckSubject

' Otherwise, just exit function.


' Destroy object variable:
GoSub CleanUp

' Set this function's return value:
MoveIfFound = RetVal

' Exit function here:
Exit Function


Set objTOPIC_FLDR = Nothing


' Reset error handler:
On Error GoTo 0

' Get subject:
strSubject = objITEM.Subject

' See if topic is found in subject;
' Ignore case by using vbTextCompare:
lngTopicFoundAtChar = InStr(1, strSubject, strTopicToFind,

' If found, carry on:
If lngTopicFoundAtChar > 0 Then GoTo MoveItem

' Otherwise, just exit function:
GoTo Bye


' Point to the topic subfolder:
Set objTOPIC_FLDR = GetMyFolder(strTopic_Fldr_Name, objPARENT_FLDR)

' Move the Mail or Post Item:

' We've moved the item, so this function's
' return value is TRUE:
RetVal = True

' Exit function:
GoTo Bye

End Function

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