# Outlook and VBA: move email items



## Archangelos (Jul 9, 2019)

*Introduction*
Take a look at the following picture.











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.




```
'[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.


----------



## John_w (Jul 10, 2019)

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:


```
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:

```
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.


----------



## Archangelos (Jul 25, 2019)

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.


```
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.








After the first run 5 email items remain unmoved.





After the second run 2 email items are still pending.





It took 3 runs to get all items moved.


----------



## Archangelos (Jul 25, 2019)

It seems very odd that one run is not enough.

An easy way to make with it the following.


```
Sub aaaaaa()
Dim i As Integer


For i = 1 To 7
    Call Code2
Next


End Sub
```

It's effective but ... why is it necessary?


----------



## John_w (Jul 25, 2019)

Try looping backwards through the items - change the For Each loop to a For i = n To 1 Step -1 loop.


----------



## Archangelos (Jul 26, 2019)

Looping backwards? Which part of the code?


----------

