Outlook VBA to Move Multiple Outlook Subfolders With Ref to Excel List

dougmarkham

Active Member
Joined
Jul 19, 2016
Messages
252
Office Version
  1. 365
Platform
  1. Windows
Hi Folks,

I am looking for some VBA code (to run from Outlook) that would: a) open an excel workbook, and b) refer to a worksheet with "source Outlook FolderPath" and "destination Outlook FolderPath" ---e.g., ws("MoveFolders") col A and B---and c) use this data to move any folder/subfolder in outlook from the source FolderPath to the destination FolderPath.

Do you know if such code is possible, as I can see no example of it via Google search?

Kind regards,

Doug.
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Try this Outlook macro, changing the Excel workbook where indicated.

The Get_Folder function shows how you should specify the folder paths of the source and destination folders.

VBA Code:
Option Explicit

Public Sub Move_Folders()

    Dim workbookFileName As String
    Dim workbookOpened As Boolean
    Dim ExcelApp As Object, ExcelWb As Object
    Dim lastRow As Long, r As Long
    Dim outSourceFolder As Outlook.MAPIFolder
    Dim outDestFolder As Outlook.MAPIFolder
    
    Const cExcelWorkbook As String = "C:\path\to\Excel Workbook.xlsx"     'CHANGE THIS
    
    On Error Resume Next
    Set ExcelApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set ExcelApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    
    workbookFileName = Dir(cExcelWorkbook)
    If workbookFileName <> vbNullString Then
        Set ExcelWb = Nothing
        workbookOpened = False
        On Error Resume Next
        Set ExcelWb = ExcelApp.Workbooks(workbookFileName)
        If ExcelWb Is Nothing Then
            Set ExcelWb = Workbooks.Open(cExcelWorkbook)
            workbookOpened = True
        End If
        On Error GoTo 0
    Else
        MsgBox cExcelWorkbook & " not found"
        Exit Sub
    End If
    
    ExcelApp.Visible = True
    Application.ActiveExplorer.Activate
    
    With ExcelWb.Worksheets("MoveFolders")
    
        lastRow = .cells(.rows.count, "A").End(xlUp).Row
        
        For r = 2 To lastRow
            
            Set outSourceFolder = Get_Folder(.cells(r, "A").Value)
            Set outDestFolder = Get_Folder(.cells(r, "B").Value)
        
            If Not outSourceFolder Is Nothing And Not outDestFolder Is Nothing Then
        
                outSourceFolder.MoveTo outDestFolder
                MsgBox "Row " & r & vbCrLf & _
                       outSourceFolder.folderPath & vbCrLf & _
                       "moved to " & vbCrLf & _
                       outDestFolder.folderPath
                
            Else
            
                MsgBox "Row " & r & vbCrLf & _
                       IIf(outSourceFolder Is Nothing, "Source folder '" & .cells(r, "A").Value & "' not found" & vbCrLf, "") & _
                       IIf(outDestFolder Is Nothing, "Destination folder '" & .cells(r, "A").Value & "' not found" & vbCrLf, "")

            
            End If
        
        Next
        
    End With
    
    If workbookOpened Then
        ExcelWb.Close SaveChanges:=False
    End If

End Sub


Private Function Get_Folder(folderPath As String, Optional ByVal outStartFolder As MAPIFolder) As MAPIFolder
    
    'Search for the specified folder path starting at the optional MAPI start folder.
    '
    'If outStartFolder is specified then start in that folder and search for the specified folder path.
    'If outStartFolder is not specified then the search starts at the specified folder path.  The folder path
    'can start with a top-level folder by prepending the folder path with "\\".  Folder names are separated by "\".
    '
    'Examples:
    '   "\\Account Name\Folder1\Subfolder1\Sub-Subfolder1"  - folders in main (active) top-level folder
    '   "\\Archive Folders\Folder1\Subfolder1"              - folders in archive folder
    '   "Folder1\Subfolder1\Sub-Subfolder1"                 - folders in main (active) top-level folder
    '
    'If the whole subfolder path is found this function returns the last subfolder as a MAPIFolder object, otherwise
    'it returns Nothing
    
    Dim NS As NameSpace
    Dim outFolder As MAPIFolder
    Dim outFolders As folders
    Dim folders As Variant
    Dim i As Long
    
    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
        If folders(i) <> "" Then
            Set outFolder = Nothing
            On Error Resume Next
            Set outFolder = outStartFolder.folders(folders(i))
            On Error GoTo 0
            Set outStartFolder = outFolder
        End If
        i = i + 1
    Wend
    
    Set Get_Folder = outFolder
    
End Function
 
Upvote 0
Hi John,

I'd like to say a big thank you for sharing this code with me! :)
I had thought this wasn't possible due to the lack of code previously posted. It has enabled me to learn more about Outlook VBA and helped me to finish a model which will save people in my company lots of time.

With regard to your code: if it were not for the fact that I forgot to tell you that the ExcelWb is password protected---and that I made a few errors---the code would have worked first time.

Thus, I went on an error checking process during which I made a few redundant code changes prior to discovering my issue.

Just in case any other relative VBA rookies like me attempt to use this code in future, I made three errors:
1) In my workbook where the paths are stored, I had a trailing space in my test "source path" that I hadn't noticed.
2) Due to my lazy thinking, I set my destination FolderPath to the intended destination path i.e., a path that didn't exist because it hadn't been created yet.
3) My ExcelWb wasn't opening properly because I used the line:
VBA Code:
Set ExcelWb = ExcelApp.Workbooks.Open(cExcelWorkbook)
... instead of...
VBA Code:
Set ExcelWb = ExcelApp.Workbooks.Open(cExcelWorkbook, ReadOnly:=True, Password:="MyPassword")


Anyway, bearing all potential ridicule: the following VBA code below is what I finally got to work for me:

VBA Code:
Option Explicit

Public Sub Move_Folders()

    Dim workbookFileName As String
    Dim workbookOpened As Boolean
    Dim ExcelApp As Object
    Dim ExcelWb As Object
    Dim ExcelSh As Object
    Dim lastRow As Long
    Dim r As Long
    Dim outSourceFolder As Outlook.MAPIFolder
    Dim outDestFolder As Outlook.MAPIFolder

    Const cExcelWorkbook As String = "S:\MyCompany\MyDepartment\Dougs jobs\Time-manager.xlsm"     'CHANGE THIS TO SUIT

    On Error Resume Next
    Set ExcelApp = GetObject(, "Excel.Application")

    If Err.Number <> 0 Then
        Set ExcelApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0

    workbookFileName = Dir(cExcelWorkbook)

    If workbookFileName <> vbNullString Then
        Set ExcelWb = Nothing
        workbookOpened = False
        On Error Resume Next
        Set ExcelWb = ExcelApp.Workbooks(workbookFileName)
        If ExcelWb Is Nothing Then
            Set ExcelWb = ExcelApp.Workbooks.Open(cExcelWorkbook, ReadOnly:=True, Password:="mypassword")
            workbookOpened = True
        End If
        On Error GoTo 0
    Else
        MsgBox cExcelWorkbook & " not found"
        Exit Sub
    End If

    ExcelApp.Visible = True
    Application.ActiveExplorer.Activate

    Set ExcelSh = ExcelWb.Worksheets("MoveFolders")
    With ExcelSh
        lastRow = ExcelSh.cells(.rows.Count, 1).End(xlUp).Row
        
    For r = 2 To lastRow

            Set outSourceFolder = Get_Folder(ExcelSh.cells(r, 1).Value)
            Set outDestFolder = Get_Folder(ExcelSh.cells(r, 2).Value)

            If Not outSourceFolder Is Nothing And Not outDestFolder Is Nothing Then
                outSourceFolder.MoveTo outDestFolder
                MsgBox "Row " & r & vbCrLf & _
                       outSourceFolder.folderPath & vbCrLf & _
                       "moved to " & vbCrLf & _
                       outDestFolder.folderPath
            Else
                MsgBox "Row " & r & vbCrLf & _
                       IIf(outSourceFolder Is Nothing, "Source folder '" & .cells(r, 1).Value & "' not found" & vbCrLf, "") & _
                       IIf(outDestFolder Is Nothing, "Destination folder '" & .cells(r, 1).Value & "' not found" & vbCrLf, "")
            End If
        Next

    End With

    If workbookOpened Then
        ExcelWb.Close SaveChanges:=False
        ExcelApp.Quit
        Set ExcelWb = Nothing
        Set ExcelApp = Nothing
    End If

End Sub


Private Function Get_Folder(folderPath As String, Optional ByVal outStartFolder As MAPIFolder) As MAPIFolder
    'Search for the specified folder path starting at the optional MAPI start folder.
    'If outStartFolder is specified then start in that folder and search for the specified folder path.
    'If outStartFolder is not specified then the search starts at the specified folder path.  The folder path
    'can start with a top-level folder by prepending the folder path with "\\".  Folder names are separated by "\".
    'Examples:
    '   "\\Account Name\Folder1\Subfolder1\Sub-Subfolder1"  - folders in main (active) top-level folder
    '   "\\Archive Folders\Folder1\Subfolder1"              - folders in archive folder
    '   "Folder1\Subfolder1\Sub-Subfolder1"                 - folders in main (active) top-level folder
    'If the whole subfolder path is found this function returns the last subfolder as a MAPIFolder object, otherwise
    'it returns Nothing

    Dim NS As NameSpace
    Dim outFolder As MAPIFolder
    Dim outFolders As folders
    Dim folders As Variant
    Dim i As Long

    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
        If folders(i) <> "" Then
            Set outFolder = Nothing
            On Error Resume Next
            Set outFolder = outStartFolder.folders(folders(i))
            On Error GoTo 0
            Set outStartFolder = outFolder
        End If

        i = i + 1
    Wend

    Set Get_Folder = outFolder

End Function


@John, I think you're a great person for taking time to share your code!

Kind regards,

Doug.
 
Upvote 0

Forum statistics

Threads
1,223,099
Messages
6,170,107
Members
452,302
Latest member
TaMere

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