Outlook VBA - Automating the moving of sub-folders via reference to a source/destination table within an Excel workbook

[dougmarkham]

Hi Folks,

I have searched the web for 'Outlook VBA code' that can query an Excel worksheet for the Outlook source FolderPath and Outlook destination FolderPath i.e., to use in an Outlook move-folder event.

So far, I've only been able to find Outlook VBA code that moves multiple sub-folders between the inbox and one specified folder i.e., I've not been able to find VBA that reads an excel file to move multiple folders from multiple different source FolderPaths multiple different Destination FolderPaths.

Basic issue:

We have Outlook task-folders that are stored nested within the Inbox as Sub-folders. The task-folders are stored under various priority sub-folders e.g., of the nesting in my Outlook exchange email account:

\\Douglas.Markham@thecompany.com\Inbox\01) Doug's Jobs\C) Top Priority\(1) Urgent - today\
\\Douglas.Markham@thecompany.com\Inbox\01) Doug's Jobs\C) Top Priority\(3) One Week\
\\Douglas.Markham@thecompany.com\Inbox\01) Doug's Jobs\D) Next Few Weeks\
\\Douglas.Markham@thecompany.com\Inbox\01) Doug's Jobs\F) Awaiting response\
...etc, and...
\\Douglas.Markham@thecompany.com\Inbox\01) Doug's Jobs\J) Completed\

As business priorities change, the tasks often get assigned a different priority and eventually get completed. I'm looking for a way to automate Outlook to move the task-folders when their priority changes ---denoted by changes in our Time-manager wb. For instance, an urgent task-folder (nested in the "\(1) Urgent - today\" subfolder) might suddenly need moving to a the sub-folder "\D) Next Few Weeks\", or it might just need sent to the "\J) Completed\" subfolder

I have other VBA for outlook that allow Folder rename and Folder creation via pointing to our Time-manager excel wb. Would anybody be able to help me construct a Function that moves folders found in the Time-manager wb?

Here is the code I have so far:

Public strSource, strDestination As String

Sub MoveFolderNamesInExcelFile()

    Dim objFolders As Outlook.Folders
    Dim objFolder As Outlook.Folder

    Dim strFilepath
    Dim xlApp As Object 'Excel.Application
    Dim xlWkb As Object ' As Workbook
    Dim xlSht As Object ' As Worksheet
    Dim rng As Object 'Range

    Set xlApp = CreateObject("Excel.Application")

    strFilepath = "S:\Dougs jobs\Time-manager.xlsm"

    If strFilepath = False Then
        xlApp.Quit
        Set xlApp = Nothing
        Exit Sub
    End If

    Set xlWkb = xlApp.Workbooks.Open(strFilepath, ReadOnly:=True, Password:="abc")
    Set xlSht = xlWkb.Worksheets("OutlookFolders")

    Dim iRow As Integer
    iRow = 2

    Set objFolders = Outlook.Application.Session.Folders("Douglas.Markham@thecompany.com").Folders

    'Specifies source FolderPath and destination FolderPath in Time-manager wb
    While xlSht.Cells(iRow, 1) <> ""
        strSource = xlSht.Cells(iRow, 1)
        strDestination = xlSht.Cells(iRow, 2)

    For Each objFolder In objFolders
        Call MoveFolders(objFolder)
    Next

    iRow = iRow + 1

    Wend

    xlWkb.Close SaveChanges:=False

    xlApp.Quit
    Set xlWkb = Nothing
    Set xlApp = Nothing
    Set objParentFolder = Nothing

    MsgBox "Complete!", vbExclamation, "Moved Folders"

End Sub

I have the below VBA Function that I'm trying to modify from a find-replace function in order to move the outlook folders:

Private Sub MoveFolders(ByVal objCurrentFolder As Outlook.Folder)

    Dim objSubfolder As Outlook.Folder 

    On Error Resume Next

    CODE HELP REQUIRED HERE
   '======== Was wondering if an IF statement can be devised i.e., in order to find the Outlook Folder Paths matching strSource and strDestination, then do the move folder event======

    'Process all folders recursively to find matches to Excel source/destination FolderPaths
    If objCurrentFolder.Folders.Count > 0 Then
       For Each objSubfolder In objCurrentFolder.Folders
           Call MoveFolders(objSubfolder)
       Next
    End If

End Sub

I am fairly new to Outlook VBA and am not sure even if this is the best approach to achieving my goal.
Please would anyone be willing to help me solve this coding challenge?

Kind regards,

Doug

P.S. Here is code that I have which can move folders in Outlook but only from two specified paths:

Sub Movefolders()
    Dim OutApp As Outlook.Application
    Dim oNS As Outlook.NameSpace
    Dim objInboxFolder As Outlook.MAPIFolder
    Dim objDestFolder As Outlook.MAPIFolder
    Dim curFolder As Outlook.MAPIFolder
   
Set OutApp = Application
Set oNS = OutApp.GetNamespace("MAPI")
   
'use the selected folder
Set curFolder = OutApp.ActiveExplorer.CurrentFolder

Set objInboxFolder = oNS.GetDefaultFolder(olFolderInbox)
Set objDestFolder = objInboxFolder.Parent.Folders("Old Projects")

' move folder
curFolder.MoveTo objDestFolder

' copy folder
'curFolder.CopyTo objDestFolder

End Sub

Option Explicit
Private Const olFolderInbox = 6

Private Sub archiveOutlookFolder()

On Error GoTo errhandler

Const AA_FOLDER As String = "Audits-Actuals"
Const DEST_FOLDER As String = "PAST Audits-Actuals"


Dim objOutlook As Object ' Outlook.Application
Dim objNamespace As Object ' Outlook.Namespace
Dim objSourceFolder As Object ' Outlook.MAPIFolder
Dim objDestFolder As Object ' Outlook.MAPIFolder
Dim objFolder As Object 'Folder
Dim AAfolderToMove As String
Dim PNAToMove As String
Dim eventFolderTomove As String
Dim foundEventFolder As Boolean

Dim olAAfolders As Object ' Outlook.Folder
Dim olFolder As Object ' Outlook.Folder

PNAToMove = ThisWorkbook.Sheets("data").Range("cleanpna").Value

On Error Resume Next

Set objOutlook = GetObject(, "Outlook.Application")

On Error GoTo 0
On Error GoTo errhandler

If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
End If

Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set olAAfolders = objSourceFolder.Parent.Folders(AA_FOLDER)

foundEventFolder = False

For Each olFolder In olAAfolders.Folders

If InStr(olFolder.Name, PNAToMove) > 0 Then
eventFolderTomove = olFolder.Name
foundEventFolder = True
Exit For
End If

Next olFolder

If Not foundEventFolder Then
MsgBox "I did not find an Outlook folder for this event to move to Past events. Please move manually.", vbCritical, "Audits\Actuals"
Exit Sub
End If

Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set objFolder = objSourceFolder.Parent.Folders(AA_FOLDER).Folders(eventFolderTomove)
Set objDestFolder = objSourceFolder.Parent.Folders(DEST_FOLDER)

If Not (objFolder Is Nothing And objDestFolder Is Nothing) Then objFolder.MoveTo objDestFolder

Set objDestFolder = Nothing
Set objFolder = Nothing
Set objSourceFolder = Nothing
Set objOutlook = Nothing
Set objDestFolder = Nothing

Exit Sub

errhandler:
MsgBox Err.Number & vbLf & Err.Description

End Sub

 

[dougmarkham]

Hi.

If you've found this thread in a google search, the answer has been posted on another thread:

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

Kind regards,

Doug.