Private Const INVALID_HANDLE_VALUE As Long= -1
Private Const MAX_PATH As Long= 260

Private Type SECURITY_ATTRIBUTES
   nLength As Long
   lpSecurityDescriptor As Long
   bInheritHandle As Long
End Type

Private Declare Function CreateDirectory Lib "kernel32" _
   Alias "CreateDirectoryA" _
  (ByVal lpPathName As String, _
   lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
    
    
Private Sub Command1_Click()

   Dim nMade As Long
   Dim buff As String
  
  'the absolute path to create
   buff = "c:\DemoByPath\Sub1\Sub2\Sub3\Sub4\Sub5\Sub6\Sub7\Sub8"
   
  'pass ByVal in case the full path is needed
  'again. The routine splits up the string when
  'passed ByRef (the default).
   nMade = CreateNestedFoldersByPath(buff)
   
  'show success
   MsgBox buff & vbCrLf & vbCrLf & _
          nMade & " subfolders created.", _
          vbInformation, "Nested Demo"

End Sub


Private Sub Command2_Click()

   Dim nMade As Long
   Dim sfolders(0 To 8) As String
  
  'the drive, main folder and subfolders
   sfolders(0) = "c:\DemoByArray"
   sfolders(1) = "Sub1"
   sfolders(2) = "Sub2"
   sfolders(3) = "Sub3"
   sfolders(4) = "Sub4"
   sfolders(5) = "Sub5"
   sfolders(6) = "Sub6"
   sfolders(7) = "Sub7"
   sfolders(8) = "Sub8"
   
   nMade = CreateNestedFoldersByArray(sfolders)
   
  'show success
   MsgBox nMade & " subfolders created.", _
          vbInformation, "Nested Demo"

End Sub


Private Function CreateNestedFoldersByPath(ByVal completeDirectory As String) As Long

  'creates nested directories on the drive
  'included in the path by parsing the final
  'directory string into a directory array,
  'and looping through each to create the final path.
  
  'The path could be passed to this method as a
  'pre-filled array, reducing the code.
  
   Dim r As Long
   Dim SA As SECURITY_ATTRIBUTES
   Dim drivePart As String
   Dim newDirectory  As String
   Dim item As String
   Dim sfolders() As String
   Dim pos As Long
   Dim x As Long
   
  'show the path to create
   Label1.Caption = "created " & completeDirectory
   
  'must have a trailing slash for
  'the GetPart routine below
   If Right$(completeDirectory, 1) <> "\" Then
      completeDirectory = completeDirectory & "\"
   End If
  
  'if there is a drive in the string, get it
  'else, just use nothing - assumes current drive
   pos = InStr(completeDirectory, ":")

   If pos Then
      drivePart = GetPart(completeDirectory, "\")
   Else: drivePart = ""
   End If

  'now get the rest of the items that
  'make up the string
   Do Until completeDirectory = ""

    'strip off one item (i.e. "Files\")
     item = GetPart(completeDirectory, "\")

    'add it to an array for later use, and
    'if this is the first item (x=0),
    'append the drivepart
     ReDim Preserve sfolders(0 To x) As String

     If x = 0 Then item = drivePart & item
     sfolders(x) = item

    'debug only
     List1.AddItem item

    'increment the array counter
     x = x + 1

   Loop

  'Now create the directories.
  'Because the first directory is
  '0 in the array, reinitialize x to -1
   x = -1
   
   Do
   
      x = x + 1
     'just keep appending the folders in the
     'array to newDirectory.  When x=0 ,
     'newDirectory is "", so the
     'newDirectory gets assigned drive:\firstfolder.
     
     'Subsequent loops adds the next member of the
     'array to the path, forming a fully qualified
     'path to the new directory.
      newDirectory = newDirectory & sfolders(x)
      
     'the only member of the SA type needed (on
     'a win95/98 system at least)
      SA.nLength = LenB(SA)
      
      Call CreateDirectory(newDirectory, SA)
      
     'debug only
      List2.AddItem newDirectory
      
   Loop Until x = UBound(sfolders)
   
  'done. Return x, but add 1 for the 0-based array.
   CreateNestedFoldersByPath = x + 1

End Function


Private Function CreateNestedFoldersByArray(sfolders() As String) As Long

   Dim SA As SECURITY_ATTRIBUTES
   Dim newDirectory As String
   Dim x As Long
   
  'initialize x to -1
   x = -1
   
   Do
   
      x = x + 1
     
     'add a trailing slash if needed
      If Right$(sfolders(x), 1) <> "\" Then
         sfolders(x) = sfolders(x) & "\"
      End If
          
      newDirectory = newDirectory & sfolders(x)
      
      SA.nLength = LenB(SA)
      Call CreateDirectory(newDirectory, SA)
      
     'debug only
      List1.AddItem sfolders(x)
      List2.AddItem newDirectory
      
   Loop Until x = UBound(sfolders)
   
   CreateNestedFoldersByArray = x + 1

End Function


Function GetPart(startStrg As String, delimiter As String) As String

'takes a string separated by "delimiter",
'splits off 1 item, and shortens the string
'so that the next item is ready for removal.

  Dim c As Integer
  Dim item As String
  
  c = 1
  
  Do

    If Mid$(startStrg, c, 1) = delimiter Then
      
      item = Mid$(startStrg, 1, c)
      startStrg = Mid$(startStrg, c + 1, Len(startStrg))
      GetPart = item
      Exit Function
    
    End If

    c = c + 1

  Loop

End Function