Code to create folder and subfolders

[JP]

Hi all,

Does anyone have code that can create parent folders automatically (if
they don't exist)?

For example I use MkDir to create folders. Currently I am doing it
this way:

MkDir FolderA
MkDir FolderA\FolderB
MkDir FolderA\FolderB\FolderC

to create FolderC

Is there a way to just write in the lowest subfolder (FolderA\FolderB
\FolderC) and Excel/VBA would create the parent folders on its own, if
they don't exist?

Thx!

--JP

 

[Michel Pierron]

Hi JP,
You can try :

Private Declare Function MakeSureDirectoryPathExists _
Lib "imagehlp.dll" (ByVal lpPath As String) As Boolean

Sub CreateDirectoryStructure()
On Error GoTo 1
MakeSureDirectoryPathExists "C:\FolderA\FolderB\FolderC\FolderD\"
Exit Sub
1: MsgBox "Error " & Err.Number & vbLf & Err.Description, 64
End Sub

Regards,
MP

 

[Crowbar via OfficeKB.com]

This will create a directory tree if it doenst exsist.

CheckDir is the important bit for you as this is the directory name you will
be looking for

I have set up an example. This should check if "C:\MatchBox\64\" exsists. If
it doenst you will be prompted and then it wil create it

Function CreateDir()

Dim Fso
Dim Answer
Dim File
Dim w As Long
Dim TargetDir As Boolean
Dim CheckDir As String
TargetDir = False

CheckDir = "C:\MatchBox\64\"
File = CheckDir
Set Fso = CreateObject("Scripting.FileSystemObject")
'Checks if the whole save directory exists, if it doesn't it finds out
what is missing

If Not Fso.folderexists(File) Then

For w = 1 To Len(CheckDir)

If Mid(CheckDir, w, 1) = "\" Then
File = Mid(CheckDir, 1, w)
Set Fso = CreateObject("Scripting.FileSystemObject")

If Not Fso.folderexists(File) Then

If TargetDir = False Then

Answer = MsgBox("The save dir '" & CheckDir & "' does not
exsit" & Chr(10) & Chr(10) & "Would you like to create it?", vbInformation +
vbYesNo, "Save Directory Error")

If Answer = vbYes Then
TargetDir = True
On Error GoTo errorhandler
MkDir File
Else
Exit Function
End If

ElseIf TargetDir = True Then
MkDir File
End If

End If

End If

Next w

End If

TargetDir = False

errorhandler:
If Err.Number > 10 Then
MsgBox "Cannot Create Dir!!!"
End If

End Function

 

[JP]

Thank you, I modified your code as follows. It's a bit awkward with
all of the IF statements, but it gets the job done. However, at my
office we use UNC paths which means the first pass causes the macro to
see every CheckDir variable as non-existent. Is there a way to account
for the initial double-slash?


Sub CreateDir()

Dim Fso As Scripting.FileSystemObject
Dim sFolder As String
Dim w As Long
Dim TargetDir As Boolean
Dim CheckDir As String

TargetDir = False

CheckDir = "\\p111filclu01\Drug\RANDOMS\NewClient\2007\DOT\"
sFolder = CheckDir
Set Fso = CreateObject("Scripting.FileSystemObject")

'Checks if the whole save directory exists, if it doesn't it finds out
what is missing

If Not Fso.folderexists(sFolder) Then
For w = 1 To Len(CheckDir)
If Mid(CheckDir, w, 1) = "\" Then
If w > 1 Then
If Mid(CheckDir, w - 1, 2) <> "\\" Then
sFolder = Mid(CheckDir, 1, w)
If Not Mid(sFolder, w, 2) = "\\" Then
If Not Fso.folderexists(sFolder) Then
If TargetDir = False Then
Select Case MsgBox("The directory '" &
CheckDir & "' does not exist" & vbCrLf & vbCrLf & "Would you like to
create it, along with with its parent folders?", vbYesNo)
Case vbYes
TargetDir = True
On Error GoTo errorhandler
MkDir sFolder
Case Else
Exit Sub
End Select
ElseIf TargetDir = True Then
MkDir sFolder
End If
End If
End If
End If
End If
End If
Next w
End If

TargetDir = False

Exit Sub

errorhandler:
If Err.Number > 10 Then
MsgBox "Cannot Create Dir!!!"
End If
End Sub

 

[JP]

Hey I thought you might like to know I found this code on Chip
Pearson's website, should do what I am looking for so I'm posting the
link.

http://www.cpearson.com/excel/MakeDirMulti.htm

Thx,
JP