Creating subdirectories in VBA when parent folder doesn't exist

Ben writes in and asks about saving Outlook emails into hard drive folders and then deleting them. He sent in a routine found on VBA Express, but it causes an error when creating directories. The problem is that if you select anything other than a top-level folder (i.e. a subfolder), it tries to create full paths (that didn't previously exist) instead of just single subdirectories under existing directories.

From VBA Express:

This macro will allow you to specify a starting folder and all emails in that folder and all sub folders will be saved to a specified folder on your hard drive. The folder hierarchy will be maintained (i.e. The files will be saved to folders that will be named and have the same structure as the Outlook folders.

Here's an example. Let's say we want to create the following directory as specified by the above procedure:

C:\Inbox\MyFolder\Some Emails\

The problem is, it's not just the Some Emails directory that doesn't exist, but the Inbox and MyFolder directories don't exist either. Therefore, the following lines of code will fail:

Scripting.FileSystemObject.CreateFolder "C:\Inbox\MyFolder\Some Emails\"

MkDir "C:\Inbox\MyFolder\Some Emails\"

So we'll need a procedure that creates the upper directories first before trying to create the child directory. I use the term directory here to refer to folders on the hard drive, and folder to refer to Outlook folders.

Sub CreateSubDirectories(fullPath As String)

Dim str As String
Dim strArray As Variant
Dim i As Long
Dim basePath As String
Dim newPath As String

str = fullPath

' add trailing slash
If Right$(str, 1) <> "\" Then
 str = str & "\"
End If

' split string into array
strArray = Split(str, "\")

basePath = strArray(0) & "\"

' loop through array and create progressively
' lower level folders
For i = 1 To UBound(strArray) - 1
  If Len(newPath) = 0 Then
    newPath = basePath & newPath & strArray(i) & "\"
  Else
    newPath = newPath & strArray(i) & "\"
  End If

  If Not FolderExists(newPath) Then
    MkDir newPath
  End If
Next i

End Sub

Function FolderExists(ByVal strPath As String) As Boolean
' from http://allenbrowne.com
   On Error Resume Next
    FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function

Sample usage

You can pass in an entire directory path, or even just a single directory you want to create. The procedure above will go through the entire path and create each folder if it doesn't already exist.

' create "Inbox\MyFolder\Some Emails\" directory tree
Call CreateSubDirectories "C:\Inbox\MyFolder\Some Emails\"

' create just the "My Emails" folder
Call CreateSubDirectories "C:\Inbox\MyFolder\Some Emails\My Emails\"

Is VBA Necessary?

Personally I find this approach (saving emails to the hard drive and then deleting them) puzzling. You're disconnecting your emails from their natural storage place (Outlook) and putting them into a tightly coupled series of directories. What happens if you need to reply to an email, or need to view a conversation thread, or even something as simple as moving an email to another folder? You'll be in a much better position if they are in a PST archive which you can reconnect to Outlook in a couple of steps. It's like trying to catch dirt with your hands instead of using the bags the vacuum cleaner company makes.

Buy a portable hard drive if necessary and use Outlook's built-in archive features to move old emails to another PST file. Hard drive space has never been cheaper. Or just strip those bulky attachments from your emails and leave a pointer to the file in the message body. You should have a Really Good Reason^TM for taking your emails completely out of Outlook.