VBA to Create Outlook Folders from a List of Folder Names in Excel

[dougmarkham]

Hi Folks,


Basic aim

I am looking to automate the adding of new email folders to Outlook 2016 for new jobs that come into our office.

• We are using Microsoft outlook 2016 through a MS 365 contract on an exchange server controlled by Microsoft.

Detail

I have created an excel model for handling new jobs. My goal is to put some VBA code into Outlook's VBA editor that:
1) Opens the excel model
2) Reads a Worksheet called OutlookFolders (see table below) containing Column A (Parent folder) and Column B (Folder names)
3) Adds a folder name matching that in Column B nested under the Parent folder in Column A.

Parent folder (A1)	Folder names (B1)
Inbox	Test Folder

I have looked into available VBA code for this purpose and all the examples are a few years old. Here is the code I have:

Create Outlook Folders from a List of Folder Names

Public Sub MoveSelectedMessages()

    Dim objParentFolder As Outlook.Folder ' parent
    Dim newFolderName 'As String
    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:\Office\JobManager.xlsm"

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

    Set xlWkb = xlApp.Workbooks.Open(strFilepath)
    Set xlSht = xlWkb.Worksheets("OutlookFolders")
    Dim iRow As Integer

    iRow = 2

'select starting parent
Set objParentFolder = Application.ActiveExplorer.CurrentFolder

Dim parentname

While xlSht.Cells(iRow, 1) <> ""
parentName = xlSht.Cells(iRow, 1)
newFolderName = xlSht.Cells(iRow, 2)

 If parentName = "Inbox" Then
 Set objParentFolder = Session.GetDefaultFolder(olFolderInbox)
    Else
 Set objParentFolder = objParentFolder.Folders(parentName)
 End If
On Error Resume Next

Dim objNewFolder As Outlook.Folder
Set objNewFolder = objParentFolder.Folders(newFolderName)

If objNewFolder Is Nothing Then
    Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
End If

    iRow = iRow + 1

 ' make new folder the parent
 ' Set objParentFolder = objNewFolder

  Set objNewFolder = Nothing
Wend
    xlWkb.Close
    xlApp.Quit
    Set xlWkb = Nothing
    Set xlApp = Nothing
    Set objParentFolder = Nothing

End Sub

I have tested this code. It opens the excel spreadsheet fine but gave the following error message when setting the object parent folder:

Run-time error '-2147221233 (8004010f)': The attempted operation failed. An object could not be found.

The line of code that the debug pointed to is:

 Set objParentFolder = objParentFolder.Folders(parentname)

Would you please help me to modify this code to work with Outlook 2016 (ms 365)?

Kind regards,

Doug

 

[ajetrumpet]

doug, you said:

It opens the excel spreadsheet fine but gave the following error message when setting the object parent folder:

Run-time error '-2147221233 (8004010f)': The attempted operation failed. An object could not be found.

The line of code that the debug pointed to is:

Set objParentFolder = objParentFolder.Folders(parentname)

the first line of relevant code as it relates to your folder object is this:

Set objParentFolder = Application.ActiveExplorer.CurrentFolder

and the next relevant line is this, which is where you claim the error occurs:

Set objParentFolder = objParentFolder.Folders(parentName)

I would assume you are getting the error because there is no subfolder that has the name *parentName* nested underneath the folder referenced by *Application.ActiveExplorer.CurrentFolder*. That makes perfect sense to me, as the error message is basically saying that exact thing. a great way to troubleshoot an error like this is to ask google, in detail, and using a sequence of keywords that the algorithm can use effectively in order to get the relevant results to you. check this out for an example of one such useful search:

https://www.google.com/search?q=outlook+vba+folders+collection+The+attempted+operation+failed.+An+object+could+not+be+found

 

[dougmarkham]

Hi Adam,

Thanks for your reply!

I realized from what you said

I would assume you are getting the error because there is no subfolder that has the name *parentName* nested underneath the folder referenced by *Application.ActiveExplorer.CurrentFolder*.

(after rechecking the instructions that came with the code) that I have to include the whole outlook folder structure from the highest level down. The code works for me now .


I have a further question if that is ok?

People have JobManager.xlsm open for most of the day but this run the code opens JobManager.xlsm prior to running. I presume the following code...

Set xlWkb = xlApp.Workbooks.Open(strFilepath)

activates the workbook prior to the line

Set xlSht = xlWkb.Worksheets("OutlookFolders")

How would it be possible to modify this code so it runs when the excel file JobManager.xlsm is already open.

Kind regards,

Doug.

 

[ajetrumpet]

Doug,

If I understand you correctly, this code line:

       Set xlWkb = xlApp.Workbooks.Open(strFilepath)

opens the book called *JobManager.xlsm*? If that's what you're saying, then if you want to run any of the code that runs subsequently after that which instantiates the workbook object in the same code:

Set xlWkb = xlApp.Workbooks.Open(strFilepath)

you need to replace that line with this:

set xlwkb = activeworkbook

and everything else should run just fine because all subsequent code lines use the workbook object assigned to the variable as a qualifier anyway.

 

[dougmarkham]

Doug,
you need to replace that line with this:

set xlwkb = activeworkbook

and everything else should run just fine because all subsequent code lines use the workbook object assigned to the variable as a qualifier anyway.

Hi Adam,

Users normally have Outlook and JobManager.xlsm open all day and create many outlook folders as new jobs come in, so this is why ideally I would like to get the code to point to an already open JobManager.xlsm workbook.

I tried this---

    Set xlWkb = ActiveWorkbook
    Set xlSht = xlWkb.Worksheets("OutlookFolders")

(which caused an error) but was able to get past this line by adapting the code to:

set xlwkb = xlApp.ActiveWorkbook
Set xlSht = xlWkb.Worksheets("OutlookFolders")

.

However, unlike when the Set xlWkb = xlApp.Workbooks.Open(strFilepath) opens the workbook, when Set xlWkb = ActiveWorkbook is used instead, an error message arises after the next line:

Set xlSht = xlWkb.Worksheets("OutlookFolders")

Interestingly, I get the same error message if I attempt to turn off EnableEvents for the ActiveWorkbook instead of Set xlSht...
E.g.,

    With xlWkb
        .Visible = True
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = True
        .Activate
    End With

However, if instead I try and run a macro after Set xlWkb = xlApp.ActiveWorkbook then I get a Run-time error '1004' for instance:

    Set xlApp = CreateObject("Excel.Application")
    
    strFilepath = "S:\APS_Logistics\Logistics Support\Dougs jobs\Time-manager.xlsm"
    If strFilepath = False Then
        xlApp.Quit
        Set xlApp = Nothing
        Exit Sub
    End If
      
    Set xlWkb = xlApp.ActiveWorkbook
    Call xlApp.Run("[ActivateOutlookFolders]")

I wonder what is causing the issue: i.e., why Set xlWkb = xlApp.Workbooks.Open(strFilepath) allows Set xlSht = xlWkb.Worksheets("OutlookFolders") but set xlwkb = xlApp.ActiveWorkbook causes a Run-time 91 error when setting the worksheet?

Kind regards,

Doug.

 

[ajetrumpet]

hmmm....I'm not really sure Doug. There's quite a bit of content in this thread at this point, so it's very possible I've gotten lost looking at all the content that's here and have missed something critical that we bot have overlooked. The only way I could be sure to know what the issue is if I saw the actual file you are working with. Do you wanna upload it? If you have sensitive data in it, you can always put fake data in it.....that's all I've got to offer you at this point sir. sorry.

 

[dougmarkham]

hmmm....I'm not really sure Doug. There's quite a bit of content in this thread at this point, so it's very possible I've gotten lost looking at all the content that's here and have missed something critical that we bot have overlooked. The only way I could be sure to know what the issue is if I saw the actual file you are working with. Do you wanna upload it? If you have sensitive data in it, you can always put fake data in it.....that's all I've got to offer you at this point sir. sorry.

Hi Adam ,

I thought I'd test the code using a freshly created workbook (JobManagerTest.xlsm) to see if it was an issue with the JobManager.xlsm workbook i.e., so I could send you a copy of JobManager.xlsm without fear that the issue is workbook specific.

When referring the VBA to JobManagerTest.xlsm instead e.g.,

strFilepath = "S:\Office\JobManagerTest.xlsm"

, the code didn't actually open an excel window when I pressed F8 to pass through line Set xlWkb = xlApp.Workbooks.Open(strFilepath).
It got me thinking, maybe the reason an excel window was opening was due to the Workbook password on JobManager.xlsm (which was not included in the code).
I added password protection onto JobManagerTest.xlsm and re-ran the code. As suspected, running the code this time caused excel to open and offer the password box to enter the pw.
I went back to the code in Outlook and replaced Set xlWkb = xlApp.Workbooks.Open(strFilepath) with Set xlWkb = xlApp.Workbooks.Open(strFilepath, Password:="correctpw"), closed JobManagerTest.xlsm and re-ran the code. This time, the VBA ran the code without the excel window opening/closing.

I then tried running the outlook code with JobManagerTest.xlsm already open; however, with the excel file open, as I pressed F8 through the line Set xlWkb = xlApp.Workbooks.Open(strFilepath, Password:="correctpw"), an excel window still opened up and offered me the password box.
At this point, I'm getting excited: I replaced Set xlWkb = xlApp.Workbooks.Open(strFilepath, Password:="correctpw"with Set xlWkb = xlApp.Workbooks.Open(strFilepath, ReadOnly:=True, Password:="correctpw") so that it would attempt to open a read-only copy.

This time, even with JobMangerTest.xlsm already open, when I ran the outlook VBA code, no excel window opened: the code ran and created the folder without issue ?!
As JobManager.xlsm saves itself every other minute, so this fix will suffice for our purposes. I guess another way would be to have new jobs in JobManager.xlsm sent to another workbook, so that Outlook can run the code pointing to that instead.

I suppose technically, I haven't managed to point to an already open file, but that might not be possible through Outlook?

Anyway, I think this is a good outcome. A massive thanks for your help Adam ? I have attached the file, and full code is below.

JobManagerTest.xlsm GoogleDrive download link

Public Sub MoveSelectedMessages()

    Dim objParentFolder As Outlook.Folder ' parent
    Dim newFolderName 'As String
    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:\Office\JobManagerTest.xlsm"

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

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

    Dim iRow As Integer

    iRow = 2

'select starting parent
Set objParentFolder = Application.ActiveExplorer.CurrentFolder

Dim parentname

While xlSht.Cells(iRow, 1) <> ""
parentname = xlSht.Cells(iRow, 1)
newFolderName = xlSht.Cells(iRow, 2)

 If parentname = "Inbox" Then
 Set objParentFolder = Session.GetDefaultFolder(olFolderInbox)
    Else
 Set objParentFolder = objParentFolder.Folders(parentname)
 End If

On Error Resume Next

Dim objNewFolder As Outlook.Folder
Set objNewFolder = objParentFolder.Folders(newFolderName)

If objNewFolder Is Nothing Then
    Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
End If

    iRow = iRow + 1

 ' make new folder the parent
 ' Set objParentFolder = objNewFolder
  Set objNewFolder = Nothing

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

End Sub

Kind regards,

Doug

 

[ajetrumpet]

so am I to assume that you're satisfied with what you have now and you don't need any further assistance? That's what it sounds like to me. I have to manage my mother's funeral over the next 2 days anyway, and then of course after that I have to talk to a ridiculously smart engineer who wants to test me on my knowledge of polymorphism and abstraction. go figure. some of these people are way to smart for their own good. Maybe see you around....

 

[dougmarkham]

so am I to assume that you're satisfied with what you have now and you don't need any further assistance? That's what it sounds like to me. I have to manage my mother's funeral over the next 2 days anyway, and then of course after that I have to talk to a ridiculously smart engineer who wants to test me on my knowledge of polymorphism and abstraction. go figure. some of these people are way to smart for their own good. Maybe see you around....

Hi Adam,

So sorry to hear about your mother!

No worries about this, I am sorted.

Organizing funerals and estates can be very stressful. Hope you're doing ok?
You're a good guy for helping others with all this going on in your life.

I'm sure you're doing alright in the 'smarts' department too: give the smart-**** engineer hell for me!

Kind regards,

Doug.

 

[ajetrumpet]

give the smart-**** engineer hell for me!

sure will. I've already given GoDaddy employees an earful regarding their massive incompetence. I think I said something to probably 10 different employees over 10 different phone calls. And of course, I dumped their services due to that. They were probably glad to get rid of me!