Create a Folder using VBA

[TheSmileyCoder]

I have often had the use to be able to create folders on a users harddrive or network drive to store files in. One of the issues however was if the parent folder did not allready exist the standard built in function MkDir would fail. So I made a custom function which would loop through, and create the directories as needed. It will return a True if the creation is succesfull. I am sure there is room for improvement, so if anyone has something to add, go ahead.

Example usage:

If MakeDir("C:\MyAppWorkfolder\2012\January") Then
    'Proceed to export file
End If

And here is code:

Public Function MakeDir(ByVal strPath As String) As Boolean
'****************************************************************************************
'* Function: MakeDir
'*
'* Author:   TheSmileyCoder
'* Version:  1.0, Dated: 2012-03-01
'* Input:    Full path to directory desired. For example: "C:\Program Files\MyTool\
'*
'* Output:   True/False indicating whether or not creation was succesfull.
'****************************************************************************************
 
'*  Known issues
'   * No error handling for cases such as network drives,
'     with restricted permissions to create folders.
'   * No input validation
 
 
On Error GoTo err_Handler
 
   'Check if rightmost char is a \
      If Right(strPath, 1) = "\" Then
         'Strip it
         strPath = Left(strPath, Len(strPath) - 1)
      End If
 
   'Check if each individual directory exists, and if not, create it
      Dim strSplitPath() As String
      strSplitPath = Split(strPath, "\")
      Dim intI As Integer
      Dim strCombined As String
 
      'Loop through, creating each directory if needed
         For intI = 0 To UBound(strSplitPath)
            If intI <> 0 Then
               strCombined = strCombined & "\"
            End If
            strCombined = strCombined & strSplitPath(intI)
            If Dir(strCombined, vbDirectory) = "" Then
               MkDir strCombined
            End If
         Next
 
   'Code ran to end without errors, so creation was succesfull
      MakeDir = True
      Exit Function
 
'**************************************
'*      Error Handler
'**************************************
err_Handler:
   MakeDir = False
   MsgBox "Error " & Err.Number & " occured." & vbNewLine & Err.Description
 
End Function