Simple move email to different folder

I am a VBA newbie to Outlook and barely understand VBA for Excel. I have looked all over for simple code I can edit that will allow me to simply move emails from specific email addresses to a folder in my Personal folders. Sounds easy but I have had no luck figuring it out. I did find Stock code but cannot figure out how to edit it for Outlook. I would have thought there would be a lot of easy samples since it seems this would be something frequently done. I want code to do this rather than using a Rule because we are limited on how many rules we are allowed to use.

I want to move emails from my default inbox folder (I believe that by using the default Inbox folder as my starting folder I do not have to use the full path) to a folder with the following path (I think)

The PST file is P:\PST\TestDataFile.pst
and I believe to get to the actual folder (TestDataFileNAMEfolder) you use this path:
\TestDataFileNAME\TestDataFileNAMEfolder


I would like to create code to move email from the email address emailaddress@sample.com to the folder noted above. Eventually I would like it to check for multiple emails and them move them to the correct corresponding folders. I guess I can figure that out possibly once I get the basics down.

I think the code below is close but I cannot figure out the code to (3) Do soemthing here....
Any help or advice would be greatly appreciated ! : pray2:

Code:

---

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    ' (1) default Inbox
    Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)
    On Error Goto ErrorHandler
    ' (2) only act if it's a MailItem
    Dim Msg As Outlook.MailItem
    If TypeName(item) = "MailItem" Then
        Set Msg = item
        ' (3) do something here  ---  NEED HELP WITH THIS SECTION
    End If
    ProgramExit:
    Exit Sub
    ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

---

You need to address the folder as it appears in Outlook, and walk the folder hierarchy down to the folder you want to reference. The folders (I assume Outlook 2003 here) are MAPIFolder objects. The MailItem.Move method takes a MAPIFolder object as its parameter.

For example, if you wanted to move the emails to Inbox\My Messages\My Folder, the code would be

Code:

---

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    ' (1) default Inbox
    Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)
    On Error Goto ErrorHandler
    ' (2) only act if it's a MailItem
    Dim Msg As Outlook.MailItem
    Dim fldr As Outlook.MAPIFolder
    If TypeName(item) = "MailItem" Then
        Set Msg = item
        If Msg.SenderEmailAddress = emailaddress@sample.com Then' edit this part
            Set fldr = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("My Messages").Folders("My Folder")       
            Msg.Move fldr
        End If
    End If
    ProgramExit:
    Exit Sub
    ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

---

Are you clear on where the code should be placed?

Thanks JP but I need the folders from a Personal folder PST file and I am not sure how to code it with the following path:

P:\PST\TestDataFile\TestDataFileNAME\TestDataFileNAMEfolder

I guess I am not clear on what would change in the code you posted - see below for the specific line I am referring to. For instance would (olFolderInbox) remain the same and if now what would it change to ? I may be able to get there with the following folders once I get started with the intial part of the code.

Code:

---

Set fldr = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("My Messages").Folders("My Folder")

---

Thanks for the help. Any advice on this ?

Oh forgot to mention also that it is Outlook 2007 and the destination folder is not related and is not a subfolder to the Inbox folder which is complicating matters I am afraid :-(

It doesn't matter that it's a personal PST, what matters is that it's open and viewable in the Navigation Pane.

I can access my default Inbox using

Code:

---

Outlook.Session.GetDefaultFolder(olFolderInbox)

---

or

Code:

---

Outlook.Session.Folders("Mailbox - JIMMY PENA").Folders("Inbox")

---

I have a local PST file on my computer. The top level is called "Archive Folders" so to access THAT Inbox the code would be

Code:

---

Outlook.Session.Folders("Archive Folders").Folders("Inbox")

---

Are you with me so far?

If the folder was in my local PST, and it was two levels below the Inbox like this:

Inbox --\
Level 1 --\
Level 2

Then I would reach it like this:

Code:

---

Outlook.Session.Folders("Archive Folders").Folders("Inbox").Folders("Level 1").Folders("Level 2")

---

The folder doesn't have to be related to the Inbox. If I had another mail folder that was on the same level as the Inbox, the code would be

Code:

---

Outlook.Session.Folders("Archive Folders").Folders("My Other Mail Folder")

---

Now you need to apply that logic to your particular situation.

One thing you do have to change is in Outlook 2007, the MAPIFolder Object no longer exists. You need to declare MAPIFolder Objects as Folder Objects instead. Otherwise the code should be the same (but always keep the Outlook 2007 Object Model Reference handy.

Quote:

---

Originally Posted by bdsii

Thanks JP but I need the folders from a Personal folder PST file and I am not sure how to code it with the following path:

P:\PST\TestDataFile\TestDataFileNAME\TestDataFileNAMEfolder

I guess I am not clear on what would change in the code you posted - see below for the specific line I am referring to. For instance would (olFolderInbox) remain the same and if now what would it change to ? I may be able to get there with the following folders once I get started with the intial part of the code.

Code:

---

Set fldr = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("My Messages").Folders("My Folder")

---

Thanks for the help. Any advice on this ?

---

Thanks for hanging in there with me on this JP. I used your code and then changed the folders as you advised. I believe I have that part correct. I also used a valid email address to test that already had emails in the Inbox that should be moved to the folder specified. I am not sure which line of code to change as you also advised to declare MAPIFolder Objects as Folder Objects instead. I placed all the code into the ThisOutlookSession area. I thought it may only work on startup so I closed down Outlook and restarted and it did not move the email. I thought it may work upon receipt of the email and tried that with no luck. I then tried creating a Module and putting all the code there and tried those two scenarios and still no luck. Can you review the code below to see if I missed something ? Also, where specifically should the VBA code go into Outlook, into a Module or ThisOutlookSession or a combination ?

Code:

---

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    ' (1) default Inbox
    Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

---

and then ....

Code:

---


Private Sub Items_ItemAdd(ByVal item As Object)
    On Error GoTo ErrorHandler
    ' (2) only act if it's a MailItem
    Dim Msg As Outlook.MailItem
    Dim fldr As Outlook.MAPIFolder
    If TypeName(item) = "MailItem" Then
        Set Msg = item
        If Msg.SenderEmailAddress = "Myname@somewhere.com" Then
            ' Original example - Set fldr = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("My Messages").Folders("My Folder")
            Set fldr = Outlook.Session.Folders("TestDataFileNAME").Folders("TestDataFileNAMEfolder")
            '  Actual path - TestDataFile\TestDataFileNAME\TestDataFileNAMEfolder
            Msg.Move fldr
        End If
    End If
    ProgramExit:
    Exit Sub
    ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

---

I figure I am missing something simple. Does this code run upon startup or does it run upon receipt ? I noticed when I placed the code into a module I could not find it when I hit F8 to run the macro.

Sorry to bother you but I tried it and tried it and cannot figure this out.

I did find one piece of code that I got to work once I had your help figuring out the folder issue. That code is below and it proves that the folder settings are correct now.

Code:

---

Sub MoveItems_EmailAddress()
    Dim myOlApp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder
    Dim myItems As Outlook.Items
    Dim myItem As Object
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myItems = myInbox.Items
    '    Set myDestFolder = myInbox.Folders("Personal Mail")
    Set myDestFolder = Outlook.Session.Folders("TestDataFileNAME").Folders("TestDataFileNAMEfolder")
    Set myItem = myItems.Find("[SenderEmailAddress] = 'Myemail@somewhere.com'")
    While TypeName(myItem) <> "Nothing"
        myItem.Move myDestFolder
        Set myItem = myItems.FindNext
    Wend
End Sub

---

So for instructional purposes, are these two pieces of code equivalent ? I have a suspicion that the original code is supposed to run upon receipt or startup whereas the one above runs upon running the macro.

Thoughts ? I appreciate your help so much :-)

This is event handler code, and should be placed in ThisOutlookSession module. You don't step through it directly, and it doesn't run on startup; it "listens" for the event it is registered for, and fires when that event occurs. In this case, whenever a new item (any item) is added to the folder you specify in the Application_Startup folder.

The process is --

1- Outlook starts, Application_Startup is run and the event handler listener is registered;
2- When a new item (ANY item; anything from an assigned task to an appointment to an email) is added to the folder specified in Application_Startup, the ItemAdd event is executed. This could be when a new item arrives, or if it is dragged and dropped into the folder.
3- Your code executes.

Note that you must restart Outlook before the event code will work, and you must restart whenever even the slightest change is made to the code.

What I do when I'm testing event code is restart Outlook, then open the VB IDE (Alt+F11) and (without making any changes to the code) set a breakpoint on the first line by clicking on the first line (the "ItemAdd" line) and pressing F9. I send an email to myself (or whatever type of object I'm testing for). Then you can step through the code, check the value of variables, and so on. If you have to make changes to the code, restart Outlook and start the process again.

To change MAPIFolder objects to Folder objects, just change the "As Outlook.MAPIFolder" references to "As Folder". It's as simple as a find and replace (Ctrl+H).

You're correct about the MoveItems_EmailAddress procedure (although I think it would fail if it ran into a non-MailItem), it's an on demand macro you can run to move items that meet a specific criteria, whereas the code we've been discussing runs automatically (as an event).

I'm (still) confused about what "P:\PST\TestDataFile\TestDataFileNAME\TestDataFileNAMEfolder" means. Is that a file path, or an Outlook folder path? It just seems odd that an Outlook folder would be called "TestDataFile", but that might be just my hangup.

Man.....I responded to you JP but it timed out for some reason.



Anyway the abbreviated version is I used the code and explanation and it worked GREAT !!! thanks so much for your help !!

I did find out that the code worked if I changed the MAPIFolders to Folders or not and I confirmed I am using Outlook 2007. I thought you would find that interesting.

Hopefully someone else coming along will find this string to be useful. I am marking it solved now.

Once again I appreciate it !!
:beerchug:

Great job, glad to hear you did it!

Quote:

---

Originally Posted by JP2112

Great job, glad to hear you did it!

---

Hi guys,

If I want to save/copy all the files from an OutlookFolder to a folder from Desktop, how can I do that?

I have this code, but because my DestFolderpAth is on "C:\Data\SR_PIXEL_Error_emails" I can;t save this.
How can I make this code to copy all my emails there?

Code:

---

For Each oitem In myItems.Restrict("[UnRead] = True")
    oitem.Save (DestFolderPath)
Next

---

Can anyone help please?

I nearly didn't look at this thread. It is a six year old thread marked as 'solved'. You would have been better served creating a new thread. However

Code:

---

Option Explicit

Sub SaveMessages()
    Dim olItems As Outlook.Items
    Dim olItem As Outlook.MailItem
    Dim olFolder As Outlook.Folder
    Dim fName As String
    Dim fPath As String
    fPath = "C:\Data\SR_PIXEL_Error_emails\"    'The folder to save the messages
    CreateFolders fPath 'Create the folder if it doesn't exist
    Set olFolder = Session.PickFolder
    Set olItems = olFolder.Items
    For Each olItem In olItems
        If olItem.Sender Like "*@somewhere.com" Then    'Replace with your domain
            fName = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                    Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.subject
        Else
            fName = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                    Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.subject
        End If
        fName = Replace(fName, Chr(58) & Chr(41), "")
        fName = Replace(fName, Chr(58) & Chr(40), "")
        fName = Replace(fName, Chr(34), "-")
        fName = Replace(fName, Chr(42), "-")
        fName = Replace(fName, Chr(47), "-")
        fName = Replace(fName, Chr(58), "-")
        fName = Replace(fName, Chr(60), "-")
        fName = Replace(fName, Chr(62), "-")
        fName = Replace(fName, Chr(63), "-")
        fName = Replace(fName, Chr(124), "-")
        SaveUnique olItem, fPath, fName
    Next olItem
    Set olItem = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
    lbl_Exit:
    Exit Sub
End Sub

Private Function CreateFolders(strPath As String)
    ' An Office macro by Graham Mayor - www.gmayor.com
    Dim strTempPath As String
    Dim lngPath As Long
    Dim vPath As Variant
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not oFSO.FolderExists(strPath) Then MkDir strPath
    Next lngPath
    lbl_Exit:
    Set oFSO = Nothing
    Exit Function
End Function

Private Function SaveUnique(oItem As Object, _
    strPath As String, strFilename As String)
    ' An Outlook macro by Graham Mayor - www.gmayor.com
    Dim lngF As Long
    Dim lngName As Long
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    lngF = 1
    lngName = Len(strFilename)
    Do While fso.FileExists(strPath & strFilename & ".msg") = True
        strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFilename & ".msg"
    lbl_Exit:
    Exit Function
End Function

---

Hi Graham,

Thank you for your code.

How can i customize it to move into my folder from C ==> "C:\Data\SR_PIXEL_Error_emails" all my unread emails from the Outlook folder "2.3.1 ERROR: Pixel Comp - SR " that have the subject==> "Auto Error Notification for PIXEL Component: Service Request"?

Thank you in advance!

I really appreciate it,
Ionut

HI Graham,

I think I solved this. I have this code. Thank you for being there!

Code:

---

Sub SaveMessages()
    Dim olItems As Outlook.Items
    Dim olItem As Outlook.MailItem
    Dim olFolder As Outlook.Folder
    Dim fName As String
    Dim fPath As String
    fPath = "C:\Data\SR_PIXEL_Error_emails\" 'The folder to save the messages
    CreateFolders fPath 'Create the folder if it doesn't exist
    Set olFolder = Session.PickFolder
    Set olItems = olFolder.Items
    For Each olItem In olItems
        If olItem.Subject Like "*Auto Error Notification for PIXEL Component: Service Request" Then
            SaveUnique olItem, fPath, fName
        End If
    Next olItem
    Set olItem = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
    lbl_Exit:
    Exit Sub
End Sub

 'An Outlook macro by Graham Mayor - www.gmayor.com
Private Function CreateFolders(strPath As String)
    Dim strTempPath As String
    Dim lngPath As Long
    Dim vPath As Variant
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not oFSO.FolderExists(strPath) Then MkDir strPath
    Next lngPath
    lbl_Exit:
    Set oFSO = Nothing
    Exit Function
End Function

 'An Outlook macro by Graham Mayor - www.gmayor.com
Private Function SaveUnique(oItem As Object, strPath As String, strFilename As String) 
    Dim lngF As Long
    Dim lngName As Long
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    lngF = 1
    lngName = Len(strFilename)
    Do While fso.FileExists(strPath & strFilename & ".msg") = True
        strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFilename & ".msg"
    lbl_Exit:
    Exit Function
End Function

---

You haven't quoted your folder structure, but if the named folder "2.3.1 ERROR: Pixel Comp - SR" is a sub folder of your default Inbox then you could use the following, if not use PickFolder instead to select the folder to process. I have added in the unread mail check and the subject check, and given that the subject will now be the same in each message, there is no real need to have the subject in the filename, so I have removed it. Similarly as you will only be checking a named folder the sent mail folder option has also been removed.

Code:

---

Sub SaveMessages()
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim olFolder As Outlook.Folder
Dim fName As String
Dim fPath As String
fPath = "C:\Data\SR_PIXEL_Error_emails\"    'The folder to save the messages
CreateFolders fPath    'Create the folder if it doesn't exist
    'Set olFolder = Session.PickFolder
    Set olFolder = Session.GetDefaultFolder(olFolderInbox).folders("2.3.1 ERROR: Pixel Comp - SR")
    Set olItems = olFolder.Items
    For Each olItem In olItems
        If olItem.UnRead = True Then
            If olItem.subject = "Auto Error Notification for PIXEL Component: Service Request" Then
                fName = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                        Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName ' & " - " & olItem.subject
                fName = Replace(fName, Chr(58) & Chr(41), "")
                fName = Replace(fName, Chr(58) & Chr(40), "")
                fName = Replace(fName, Chr(34), "-")
                fName = Replace(fName, Chr(42), "-")
                fName = Replace(fName, Chr(47), "-")
                fName = Replace(fName, Chr(58), "-")
                fName = Replace(fName, Chr(60), "-")
                fName = Replace(fName, Chr(62), "-")
                fName = Replace(fName, Chr(63), "-")
                fName = Replace(fName, Chr(124), "-")
                SaveUnique olItem, fPath, fName
            End If
        End If
    Next olItem
    Set olItem = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
lbl_Exit:
    Exit Sub
End Sub

---

Hi Graham,

I got an error at the lines Createfolders fPath and SaveUnique olItem. the error is Compile error Sub or Function not defined.

Man,

I got it! nothing else to do! Thank you very much!