Outlook and VBA: move email items

A

Archangelos

New Member
Joined
Aug 21, 2017
Messages
49
Introduction
Take a look at the following picture.


7FCvA0e.png





There are two Outlook data files, their root folders are named “_FMMB” and “_Middle”. Both files have and subfolders and subfolders in subfolders.

A number of emails are moved from Inbox to folder “_Middle\000_Arrive” manually (I prefer it that way).

The code should move all emails from folder “_Middle\000_Arrive” to a folder in either “_FMMB” or “_Middle” based on the email’s subject.









The code
I am a little bit experienced in utilizing VBA in MS Excel but totally newbie when it comes to Outlook. I got a little bit confused with Namespace, MAPI and other stuff.

I searched the Internet and I made my first attempt. I scanned the folder (“_Middle\000_Arrive”), read the subjects of the email and displayed them in a Message Box.

Here is the code, a last step is pending.



Code: 
'[VBA][KTZ] Archive emails: 001
Sub ArchiveEmails() 'Primary code part from: https://www.encodedna.com/excel/how-to-parse-outlook-emails-and-show-in-excel-worksheet-using-vba.htm
Dim Thema As String
Dim FinalFolder As String
   
   
   
    On Error GoTo ErrHandler
   
    ' SET Outlook APPLICATION OBJECT.
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
   
    ' CREATE AND SET A NameSpace OBJECT.
    Dim objNSpace As Object
    ' THE GetNameSpace() METHOD WILL REPRESENT A SPECIFIED NAMESPACE.
    Set objNSpace = objOutlook.GetNamespace("MAPI")
   
    ' CREATE A FOLDER OBJECT.
    Dim myFolder As Object
        Set myFolder = GetFolderPath("_Middle\000_Arrive") '.Items
    Dim Item As Object
   
 
 
    ' LOOP THROUGH EACH ITEMS IN THE FOLDER.
    For Each Item In myFolder.Items
        If Item.Class = olMail Then
       
            Dim objMail As Outlook.MailItem
            Set objMail = Item
            'MsgBox objMail.Subject 'SO FAR IT WORKED
            Thema = objMail.Subject
         End If
       
         Select Case Thema
                Case Is >= "modular.xlsm"
                     FinalFolder = "_Middle\200_Backup\201_Equipment\201-02_Modular"
                Case Is >= "matrix.xlsm"
                     FinalFolder = "_Middle\200_Backup\201_Equipment\201-01_Matrix"
                Case Is >= "matrix.vsd"
                     FinalFolder = "_Middle\200_Backup\201_Equipment\201-01_Matrix"
                Case Is >= "ITH.xlsm"
                     FinalFolder = "_Middle\200_Backup\202_Services\202-01_ITH"
                Case Is >= "FLH.xlsm"
                     FinalFolder = "_Middle\200_Backup\202_Services\202-01_FLH"
                Case Is >= "NFL.xlsm"
                     FinalFolder = "_Middle\200_Backup\202_Services\202-01_NFL"
                Case Is >= "issue301.xlsm"
                     FinalFolder = "_FMMB\300\301"
                Case Is >= "issue302.xlsm"
                     FinalFolder = "_FMMB\300\302"
                Case Is >= "issue501.xlsm"
                     FinalFolder = "_FMMB\500\501"
                Case Is >= "issue502.xlsm"
                     FinalFolder = "_FMMB\500\502"
                Case Else
                     'Nothing to be done
End Select
       
        'HERE SOMETHING IS MISSING
        'THE REST OF THE CODE SHOULD MOVE THE EMAILS
       
       
 
    Next
    Set objMail = Nothing
  
    ' RELEASE.
    Set objOutlook = Nothing
    Set objNSpace = Nothing
    Set myFolder = Nothing
ErrHandler:
    Debug.Print Err.Description
End Sub
 
 
 
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
'https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
       
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function
       
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

Any help would be appreciated.
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
Completely untested, but I don't think the GetFolderPath function will find the top-level folder "_Middle" or "_FMMB", even if you prepend it with two back slashes "\\ " (e.g. "\\_FMMB\500\502").

Instead, add this function, which returns the MAPIFolder for the specified folder path, including optional top-level folder:

Code: 
Private Function Get_Folder2(folderPath As String, Optional ByVal outStartFolder As MAPIFolder) As MAPIFolder
    
    Dim NS As NameSpace
    Dim outFolders As folders, outFolder As MAPIFolder
    Dim folders As Variant
    Dim i As Integer
    
    Set NS = Application.GetNamespace("MAPI")
    
    If outStartFolder Is Nothing Then
    
        If Left(folderPath, 2) = "\\" Then
            
            'folderPath starts with a top level folder ("\\Folder name\xxx\yyy"), so look for that
            'folder and if found set outStartFolder to it
            
            folders = Split(Mid(folderPath, 3), "\")
            Set outFolders = NS.folders
            Set outStartFolder = Nothing
            i = 1
            While i <= outFolders.Count And outStartFolder Is Nothing
                Set outFolder = outFolders(i)
                If outFolder.Name = folders(0) Then Set outStartFolder = outFolder
                i = i + 1
            Wend
            
            i = 1   'match folder paths from 2nd folder in path
            
        Else
        
            'Top level folder not specified, so start subfolders search at parent folder of the Inbox
            
            Set outStartFolder = NS.GetDefaultFolder(olFolderInbox).Parent
            folders = Split(folderPath, "\")
            i = 0
            
        End If
        
    Else
    
        folders = Split(folderPath, "\")
        i = 0
    
    End If
    
    Set outFolder = outStartFolder
    While i <= UBound(folders) And Not outFolder Is Nothing
        Set outFolder = Nothing
        On Error Resume Next
        Set outFolder = outStartFolder.folders(CStr(folders(i)))
        On Error GoTo 0
        Set outStartFolder = outFolder
        i = i + 1
    Wend
    
    Set Get_Folder2 = outFolder
    
End Function
and replace your loop with this code:
Code: 
    Dim objMail As Outlook.MailItem
    Dim outFolder As Outlook.MAPIFolder

    'LOOP THROUGH EACH ITEMS IN THE FOLDER.
    For Each Item In myFolder.Items
        If Item.Class = olMail Then
       
            Set objMail = Item
            'MsgBox objMail.Subject 'SO FAR IT WORKED
            Thema = objMail.Subject
            
            Select Case Thema
                Case Is >= "modular.xlsm"
                     FinalFolder = "\\_Middle\200_Backup\201_Equipment\201-02_Modular"
                Case Is >= "matrix.xlsm"
                     FinalFolder = "\\_Middle\200_Backup\201_Equipment\201-01_Matrix"
                Case Is >= "matrix.vsd"
                     FinalFolder = "\\_Middle\200_Backup\201_Equipment\201-01_Matrix"
                Case Is >= "ITH.xlsm"
                     FinalFolder = "\\_Middle\200_Backup\202_Services\202-01_ITH"
                Case Is >= "FLH.xlsm"
                     FinalFolder = "\\_Middle\200_Backup\202_Services\202-01_FLH"
                Case Is >= "NFL.xlsm"
                     FinalFolder = "\\_Middle\200_Backup\202_Services\202-01_NFL"
                Case Is >= "issue301.xlsm"
                     FinalFolder = "\\_FMMB\300\301"
                Case Is >= "issue302.xlsm"
                     FinalFolder = "\\_FMMB\300\302"
                Case Is >= "issue501.xlsm"
                     FinalFolder = "\\_FMMB\500\501"
                Case Is >= "issue502.xlsm"
                     FinalFolder = "\\_FMMB\500\502"
                Case Else
                     'Nothing to be done
                     FinalFolder = ""
           End Select
       
           If FinalFolder <> "" Then
                Set outFolder = Get_Folder2(FinalFolder)
                If Not outFolder Is Nothing Then
                    objMail.Move outFolder
                Else
                    MsgBox "Folder not found: " & FinalFolder
                End If
            End If
            
        End If

    Next
    
    Set objMail = Nothing
Again, everything is uncompiled and untested for your specific usage.
 
Last edited:
Upvote 0
John_w, you did a hell of a job. Thanks buddy.

I had to do a little work, the variables' declaration was missing from your code. I also had to do a few minor corrections. The following code worked.

Code: 
Sub Code2()Dim FinalFolder As String


Dim objMail As Outlook.MailItem
    Dim outFolder As Outlook.MAPIFolder


    ' CREATE A FOLDER OBJECT.
    Dim myFolder As Object
    Dim Item As Object
        Set myFolder = Get_Folder2("\\_Middle\000_Arrive") '.Items








    'LOOP THROUGH EACH ITEMS IN THE FOLDER.
    For Each Item In myFolder.Items
        If Item.Class = olMail Then
       
            Set objMail = Item
            'MsgBox objMail.Subject 'SO FAR IT WORKED
            Thema = objMail.Subject
            
            Select Case Thema
                Case Is = "modular.xlsm"
                     FinalFolder = "\\_Middle\200_Backup\201_Equipment\201-02_Modular"
                Case Is = "matrix.xlsm"
                     FinalFolder = "\\_Middle\200_Backup\201_Equipment\201-01_Matrix"
                Case Is = "matrix.vsd"
                     FinalFolder = "\\_Middle\200_Backup\201_Equipment\201-01_Matrix"
                Case Is = "ITH.xlsm"
                     FinalFolder = "\\_Middle\200_Backup\202_Services\202-01_ITH"
                Case Is = "FLH.xlsm"
                     FinalFolder = "\\_Middle\200_Backup\202_Services\202-02_FLH"
                Case Is = "NFL.xlsm"
                     FinalFolder = "\\_Middle\200_Backup\202_Services\202-03_NFL"
                Case Is = "issue301.xlsm"
                     FinalFolder = "\\_FMMB\300\301"
                Case Is = "issue302.xlsm"
                     FinalFolder = "\\_FMMB\300\302"
                Case Is = "issue501.xlsm"
                     FinalFolder = "\\_FMMB\500\501"
                Case Is = "issue502.xlsm"
                     FinalFolder = "\\_FMMB\500\502"
                Case Else
                     'Nothing to be done
                     FinalFolder = ""
           End Select
       
           If FinalFolder <> "" Then
                Set outFolder = Get_Folder2(FinalFolder)
                If Not outFolder Is Nothing Then
                    objMail.Move outFolder
                Else
                    MsgBox "Folder not found: " & FinalFolder
                End If
            End If
            
        End If


    Next
    
    Set objMail = Nothing




End Sub


Private Function Get_Folder2(folderPath As String, Optional ByVal outStartFolder As MAPIFolder) As MAPIFolder
    
    Dim NS As NameSpace
    Dim outFolders As folders, outFolder As MAPIFolder
    Dim folders As Variant
    Dim i As Integer
    
    Set NS = Application.GetNamespace("MAPI")
    
    If outStartFolder Is Nothing Then
    
        If Left(folderPath, 2) = "\\" Then
            
            'folderPath starts with a top level folder ("\\Folder name\xxx\yyy"), so look for that
            'folder and if found set outStartFolder to it
            
            folders = Split(Mid(folderPath, 3), "\")
            Set outFolders = NS.folders
            Set outStartFolder = Nothing
            i = 1
            While i <= outFolders.Count And outStartFolder Is Nothing
                Set outFolder = outFolders(i)
                If outFolder.Name = folders(0) Then Set outStartFolder = outFolder
                i = i + 1
            Wend
            
            i = 1   'match folder paths from 2nd folder in path
            
        Else
        
            'Top level folder not specified, so start subfolders search at parent folder of the Inbox
            
            Set outStartFolder = NS.GetDefaultFolder(olFolderInbox).Parent
            folders = Split(folderPath, "\")
            i = 0
            
        End If
        
    Else
    
        folders = Split(folderPath, "\")
        i = 0
    
    End If
    
    Set outFolder = outStartFolder
    While i <= UBound(folders) And Not outFolder Is Nothing
        Set outFolder = Nothing
        On Error Resume Next
        Set outFolder = outStartFolder.folders(CStr(folders(i)))
        On Error GoTo 0
        Set outStartFolder = outFolder
        i = i + 1
    Wend
    
    Set Get_Folder2 = outFolder
    
End Function

However, I have a small issue. When the code runs it does not move all email items.



Initially, I have 12 email items.
eMeXBC9.png





After the first run 5 email items remain unmoved.
TbnAJV6.png


After the second run 2 email items are still pending.
gkO01B9.png


It took 3 runs to get all items moved.
LlTbPK0.png
 
Upvote 0
It seems very odd that one run is not enough.

An easy way to make with it the following.

Code: 
Sub aaaaaa()
Dim i As Integer


For i = 1 To 7
    Call Code2
Next


End Sub

It's effective but ... why is it necessary?
 
Last edited:
Upvote 0
Try looping backwards through the items - change the For Each loop to a For i = n To 1 Step -1 loop.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
Automating Outlook Using Custom Tags in Email Templates
Replies
0
Views
565
brncao
B
H
  • Solved
Problem with Application.FileDialog(msoFileDialogFolderPicker) in Outlook
Replies
2
Views
848
Hermac
H
O
  • Question Question
Outlook VBA to detect non-password protected attachements
Replies
0
Views
1K
Oredo
O
J
  • Question Question
Parse HTML table or extract Outlook body items to excel sheet
Replies
2
Views
537
Jaffirahamed
J
larinda4
  • Question Question
VBA: Send Outlook Email & Attach PDF
Replies
1
Views
615
Trebor76
T

Forum statistics

Threads
1,223,947
Messages
6,175,562
Members
452,652
Latest member
eduedu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top