CreateAllDirs

Public Function CreateAllDirs(ByVal strPathName _
As String) As Boolean
'Recursively creates non-existing directories from

'the given path name

Dim strTempPath As String
Dim intPathChar As Integer
On Error Goto errCreateAllDirs
Do While Not IsDirExist(strPathName)
'Loop and parse through the string

intPathChar = InStr(intPathChar + 1, strPathName & _
IIf(Right(strPathName, 1) = "\", "", "\"), "\")
If intPathChar = 0 Then Exit Do
'Create the path name

strTempPath = Mid(strPathName, 1, intPathChar - 1)
MkDir strTempPath
Loop
CreateAllDirs = True
Exit Function
errCreateAllDirs:
Select Case Err.Number
Case 75
' Ignore errors for existing paths

Resume Next
Case Else
MsgBox Err.Number & Err.Description
End Select

End Function