Create New SubFolder

[jeran042]

Good morning all,

I have a command button on a form that will create a new subfolder within each folder in a specified directory. This code runs fine, but I would like any input if this is the best way to do this, or if I am missing something crucial.

Here is what I have for code:

Private Sub Command28_Click()

Dim RootFolder      As Object
Dim SubFolder       As Object
Dim myFolder        As String
Dim myNewFolder     As String
Dim mySubfolderPath As String
Dim myFile          As String
Dim sFolderName     As String

Set fso = CreateObject("Scripting.FileSystemObject")

'User input box to get the desired new folder name
    sFolderName = Trim(UCase(InputBox("Enter Folder Name:", "CREATE NEW FOLDER")))
        
        'Test if "Cancel" button was pushed
            If sFolderName = ""  Then Exit Sub

'Confirm new folder name
    If MsgBox("Folder Name: " & sFolderName, vbInformation + vbYesNo, "CONFIRM FOLDER NAME") = vbNo Then Exit Sub
        
        
'Change to identify your main folder - MAKE SURE TO HAVE THE TRAILING "\"
    myFolder = "C:\Users\jrenald\Desktop\TEST\"

Set RootFolder = fso.GetFolder(myFolder)

'Loop through all subfolders in parent directory
    For Each SubFolder In RootFolder.SubFolders
            mySubfolderPath = SubFolder.path
            myNewFolder = mySubfolderPath & "\" & sFolderName
            'Debug.Print SubFolder.path & "\" & sFolderName
        If Not fso.FolderExists(myNewFolder) Then
            MkDir (myNewFolder)
        Else
            MsgBox "The Folder Name: " & "'" & sFolderName & "'" & " Already Exists!" _
                    & vbNewLine & "Please use that folder, or create a new one", vbCritical, "DUPLICATE NAME WARNING"
            Exit Sub
        End If

    Next SubFolder

'Conformation message that folders have been created
  MsgBox "Your New Folder: " & sFolderName _
            & vbNewLine & "Has been added to the following Directory of Subfolders: " _
            & myFolder, vbInformation, "SUCCESS!"
            
    
End Sub

The basis for this code came from "Barb Reinhardt" from:
http://answers.microsoft.com/en-us/msoffice/forum/msoffice_other-msoffice_custom-mso_2010/create-subfolders-using-vba/39419be9-60d1-4fd1-8b3c-e3ca0eaf54c2

Any input would be well appreciated!

 

[NauticalGent]

As good as any I have seen. I personally use something different from a deceased member (ChrisO), but to my semi-(un)trained eye, this looks like it will get the job done.

 

[MarkK]

At a glance, the worst thing about that code is the inconsistent indents, to me. Understanding code is hard, and understanding messy code is harder.
Mark

 

[jeran042]

As good as any I have seen. I personally use something different from a deceased member (ChrisO), but to my semi-(un)trained eye, this looks like it will get the job done.

It definitely does get the job done,
My concern is I do not have any error handling,
I'm sure I am leaving myself open to some potential error.

No checking for illegal characters perhaps??

 

[NauticalGent]

Very good point, I got so wrapped up in what the code was doing I didn’t even notice. At a minimum you should have a generic exit handler that resumes your exit handler so you can exit gracefully.

Are you asking for advice in how to do this?

 

[jeran042]

Very good point, I got so wrapped up in what the code was doing I didn’t even notice. At a minimum you should have a generic exit handler that resumes your exit handler so you can exit gracefully.

Are you asking for advice in how to do this?

After I posted, I edited the code a little. I was trying to account for the point that mark made about inconsistent indentation, and the error handling. Here is what I have:

Private Sub Command28_Click()
'https://answers.microsoft.com/en-us/msoffice/forum/msoffice_other-msoffice_custom-mso_2010/create-subfolders-using-vba/39419be9-60d1-4fd1-8b3c-e3ca0eaf54c2

'Error handling
    On Error GoTo Error_Handler
    
Dim RootFolder      As Object
Dim SubFolder       As Object
Dim myFolder        As String
Dim myNewFolder     As String
Dim mySubfolderPath As String
Dim myFile          As String
Dim sFolderName     As String

Set fso = CreateObject("Scripting.FileSystemObject")

'User input box to get the desired new folder name
    sFolderName = Trim(UCase(InputBox("Enter Folder Name:", "CREATE NEW FOLDER")))
        
'Test if "Cancel" button was pushed
    If sFolderName = "" Then Exit Sub

'Confirm new folder name
    If MsgBox("Folder Name: " & sFolderName, vbInformation + vbYesNo, "CONFIRM FOLDER NAME") = vbNo Then Exit Sub
        
'Change to identify your main folder - MAKE SURE TO HAVE THE TRAILING "\"
    myFolder = "C:\Users\jrenald\Desktop\test\"

Set RootFolder = fso.GetFolder(myFolder)

'Loop through all subfolders in parent directory
    For Each SubFolder In RootFolder.SubFolders
            mySubfolderPath = SubFolder.path
            myNewFolder = mySubfolderPath & "\" & sFolderName
            Debug.Print SubFolder.path & "\" & sFolderName
        If Not fso.FolderExists(myNewFolder) Then
            MkDir (myNewFolder)
        Else
            MsgBox "The Folder Name: " & "'" & sFolderName & "'" & " Already Exists!" _
                    & vbNewLine & "Please use that folder, or create a new one", vbCritical, "DUPLICATE NAME WARNING"
        Exit Sub
        End If

    Next SubFolder

'Conformation message that folders have been created
    MsgBox "Your New Folder: " & sFolderName _
            & vbNewLine & "Has been added to the following Directory of Subfolders: " _
            & myFolder, vbInformation, "SUCCESS!"
            
'Error handling
Error_Handler_Exit:
    Exit Sub
    
Error_Handler:
    Err.Clear
    MsgBox "Something Went Wrong!"
    Resume Error_Handler_Exit
   
End Sub

Thinking of adding a function for checking for illegal characters, I found this, nut unsure how to incorporate into my code:

Option Explicit 
 
Function BadChar(strText As String) As Long 
     '
     '****************************************************************************************
     '       Title       BadChar
     '       Target Application:  any
     '       Function    test for the presence of charcters that can not be used in
     '                   the name of an xlsheet, file, directory, etc
     '
     '           if no bad characters are found, BadChar = 0 on return
     '           if any bad character is found, BadChar = i where i is the index (in strText)
     '               where bad char was found
     '       Limitations:    passed string variable should not include any path seperator
     '                           characters
     '                       stops and exits when 1st bad char is found so # of bad chars
     '                           is not really known
     '       Passed Values:
     '           strText     [in, string]  text string to be examined
     '
     '****************************************************************************************
     '
     '
    Dim BadChars    As String 
    Dim I           As Long 
    Dim J           As Long 
     
    BadChars = ":\/?*[]" 
    For I = 1 To Len(BadChars) 
        J = InStr(strText, Mid(BadChars, I, 1)) 
        If J > 0 Then 
            BadChar = J 
            Exit Function 
        End If 
    Next I 
    BadChar = 0 
     
End Function

Perhaps:

 

[NauticalGent]

To incorporate into your code:

Private Sub Command28_Click()
'https://answers.microsoft.com/en-us/msoffice/forum/msoffice_other-msoffice_custom-mso_2010/create-subfolders-using-vba/39419be9-60d1-4fd1-8b3c-e3ca0eaf54c2

'Error handling
    On Error GoTo Error_Handler
    
Dim RootFolder      As Object
Dim SubFolder       As Object
Dim myFolder        As String
Dim myNewFolder     As String
Dim mySubfolderPath As String
Dim myFile          As String
Dim sFolderName     As String

Set fso = CreateObject("Scripting.FileSystemObject")

'User input box to get the desired new folder name
    sFolderName = Trim(UCase(InputBox("Enter Folder Name:", "CREATE NEW FOLDER")))

[COLOR="Red"]If BadChar(sFolderName) <> 0 Then
    GoTo  Err_Handler     
End If[/COLOR]

'Test if "Cancel" button was pushed
    If sFolderName = "" Then Exit Sub

'Confirm new folder name
    If MsgBox("Folder Name: " & sFolderName, vbInformation + vbYesNo, "CONFIRM FOLDER NAME") = vbNo Then Exit Sub
        
'Change to identify your main folder - MAKE SURE TO HAVE THE TRAILING "\"
    myFolder = "C:\Users\jrenald\Desktop\test\"

Set RootFolder = fso.GetFolder(myFolder)

'Loop through all subfolders in parent directory
    For Each SubFolder In RootFolder.SubFolders
            mySubfolderPath = SubFolder.path
            myNewFolder = mySubfolderPath & "\" & sFolderName
            Debug.Print SubFolder.path & "\" & sFolderName
        If Not fso.FolderExists(myNewFolder) Then
            MkDir (myNewFolder)
        Else
            MsgBox "The Folder Name: " & "'" & sFolderName & "'" & " Already Exists!" _
                    & vbNewLine & "Please use that folder, or create a new one", vbCritical, "DUPLICATE NAME WARNING"
        Exit Sub
        End If

    Next SubFolder

'Conformation message that folders have been created
    MsgBox "Your New Folder: " & sFolderName _
            & vbNewLine & "Has been added to the following Directory of Subfolders: " _
            & myFolder, vbInformation, "SUCCESS!"
            
'Error handling
Error_Handler_Exit:
    Exit Sub
    
Error_Handler:
    Err.Clear
    MsgBox "Something Went Wrong!"
    Resume Error_Handler_Exit
   
End Sub

You could add additional error handler like a customized message regarding illegal characters in the path name. I would recommend that in fact, but you hopefully get the idea on how to use that function.

 

[jeran042]

NauticalGent,

I do,
Thank you for all your help!!
I am going to expand on this on Monday.
This code started as basic, but is really starting to take shape!

Thanks again, have a great weekend!

 

[NauticalGent]

Happy to help, have a great weekend as well!

 

[NauticalGent]

Your code for checking for illegal characters made me wonder if the method I am using does. So I went to the source to check and sure enough, ChrisO had thought of that and I would have been shocked had he not.

One of our AWF Mods, Pbaldy, has hosted ChirsO's files on his site:
http://baldyweb.com/ChrisOSamples.htm

Give it a look over...

 

[Cronk]

Another point. Being old school, I clear every object I create ie

Error_Handler_Exit:
    on error resume next
    [COLOR=Red]set RootFolder= nothing[/COLOR]
    .........

    Exit Sub

 

[arnelgp]

yiu can simply do:

if dir(path)<>vbnullstring
' path exist
else
'create folder
dim varpath ad variant
var as variant
dim thisfolder as string
varpath=split(path, "\")
on error resume next
for each var in varpath
srtfolder=strfolder & var
if instr(var & "", ":")=0
mkdir strfolder
end if
strfolder =strfolder & "\"
next var
end if