Create a folder set at a specific time

Hi. My VBA skills are pretty basic as I am only recently out of college. I'm trying to create a macro for Outlook that will create some folders for me on the 1st of the month.

I have a folder called "Completed Projects." Inside that folder is a set of folders corresponding to a month of the year. (Currently they are February through July). Each month, on the first of the month, I have to manually go in and create a new "month" folder and then 4 subfolders inside it, aptly named priority 1, priority 2, priority 3, and priority 4. To make my life a little easier, I built the following code to create the 4 "priority" folders inside the folder I have selected/targeted (by clicking on it):

Code:

---

Sub CreateFolders()Dim CurrentFolder As Outlook.MAPIFolder
Dim Subfolder As Outlook.MAPIFolder
Dim List As New VBA.Collection
Dim Folders As Outlook.Folders
Dim Item As Variant


List.Add Array("Priority 1", olFolderInbox)
List.Add Array("Priority 2", olFolderInbox)
List.Add Array("Priority 3", olFolderInbox)
List.Add Array("Priority 4", olFolderInbox)


Set CurrentFolder = Application.ActiveExplorer.CurrentFolder
Set Folders = CurrentFolder.Folders
For Each Item In List
    Folders.Add Item(0), Item(1)
Next


End Sub

---

I was hoping to get some help with the rest of the code as I am at a loss as to what to do. In short these things are where I am a bit stuck:

1. I want the code to automatically do this process on the first of the month if possible. Time doesn't necessarily matter, but date does. Having to click to start the macro is fine.
2. It would be nice if it could identify the current month and create that month's folder (titled the name of the month) in the "Completed Projects" folder
3. Then it needs to create the four subfolders within that month.
4. The final folderpath would look like inbox/Completed Projects/Month Name/priority folder 1 - 4

The company-I-work for's rules automatically delete any email messages that are 6 months or older. If this empties a folder, the folder is deleted. So, there shouldn't be any concern about accidentally creating folders with the same name (ie; there will never be two June's at the same time).

Can anybody help me finish out my code?

Try this code:

Code:

---

Private Sub Application_Startup()
    Dim oFlder As Outlook.Folder
    Dim oSubFolder As Outlook.Folder
    Dim strMonth As String
    Dim boolExists As Boolean
    Dim i As Long
   
    For Each oFlder In Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders
     
      If oFlder.Name = "My Completed Projects" Then
        boolExists = True
        Exit For
      End If
    Next oFlder
   
    If Not boolExists Then
      Set oFlder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders.Add(Name:="My Completed Projects")
    End If
   
    boolExists = False
    strMonth = Format(Date, "mmmm")
   
    For Each oSubFolder In oFlder.Folders
      If oSubFolder.Name = strMonth Then
        boolExists = True
        Exit For
      End If
    Next oSubFolder
   
    If Not boolExists Then
      Set oSubFolder = oFlder.Folders.Add(Name:=strMonth)
     
      For i = 1 To 4
        oSubFolder.Folders.Add Name:="Priority " & CStr(i)
      Next i
    End If
   
   
End Sub

---

Artik