Нужен исходник по созданию определенного количества папок

Private Sub Command1_Click()
Dim n As Integer, Name1 As String, i As Integer
On Error Resume Next
n = Int(InputBox("Введите количество папок"))
Name1 = InputBox("Введить путь и основное имя папки (например с:\New_Dir")
    For i = 1 To n
        MkDir Name1 & i
       
      If FolderExists(Name1 & i) = False Then
        Print "Не удалось создать  " & Name1 & i
      Else
        Print "Создана  " & Name1 & i
      End If
    Next
    Exit Sub
If Err Then MsgBox "Что то пошло не так": Err.Clear
End Sub
 
Public Function FolderExists(ByVal strPathName As String) As Boolean
On Error Resume Next
FolderExists = GetAttr(strPathName) And vbDirectory
End Function

Option Explicit
 
Private Sub Command1_Click()
Dim n As Integer, Name1 As String, i As Integer, d() As String, Ima As String
Cls
On Error Resume Next
n = Int(InputBox("Введите количество папок"))
'Name1 = InputBox("Введите путь и основное имя папки (например C:\New_Dir")
Name1 = Text1.Text
d = Split(Name1, "\")
' Создаем подпапки
    For i = 0 To UBound(d) - 1
     Ima = Ima & d(i) & "\"
     MkDir Ima
    Next
 
    For i = 1 To n
        MkDir Name1 & i
       
      If FolderExists(Name1 & i) = False Then
        Print "Не удалось создать  " & Name1 & i
      Else
        Label2 = "Созданна папок " & Name1 & i
      End If
    Next
    Exit Sub
If Err Then MsgBox "Что-то пошло не так": Err.Clear
End Sub
 
Public Function FolderExists(ByVal strPathName As String) As Boolean
On Error Resume Next
FolderExists = GetAttr(strPathName) And vbDirectory
End Function

Private Sub Command1_Click()
Dim n As Integer, Name1 As String, i As Integer, d() As String, Ima As String
Cls
On Error Resume Next
n = Int(InputBox("Введите количество папок"))
'Name1 = InputBox("Введить путь и основное имя папки (например с:\New_Dir")
Name1 = Text1.Text
d = Split(Name1, "\")
' Создаем подпапки
    For i = 0 To UBound(d) - 1
     Ima = Ima & d(i) & "\"
     MkDir Ima
    Next
Dim St As String
    For i = 1 To n
    St = Right(String(4, "0") & i, 4) 'Добавляем перед номером нули до 4-х знаков
       MkDir Name1 & St
       
      If FolderExists(Name1 & St) = False Then
        Print "Не удалось создать  " & Name1 & St
      Else
        Print "Создана  " & Name1 & St
      End If
    Next
    Exit Sub
If Err Then MsgBox "Что то пошло не так": Err.Clear
End Sub

Option Explicit
Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
 
Private Sub Command1_Click()
Dim ErrorCode As Integer, message As String, DirPath As String
Dim i As Integer, n As Integer, St As String, m As Integer
List1.Clear
n = Int(InputBox("Введите колличество папок"))
 
    For i = 1 To n
      
        St = Right(String(4, "0") & i, 4) 'Добавляем перед номером нули до 4-х знаков
        
         DirPath = Text1.Text & St
         ErrorCode = SHCreateDirectoryEx(Me.hwnd, DirPath, ByVal 0&)
         Select Case ErrorCode
         Case 0
             message = "Папка успешно создана": m = m + 1 'подсчитываем созданные папки
         Case 80, 183
             message = "Уже есть такая папка"
         Case 161
             message = "Плохое имя папки"
         Case 206
             message = "Очень длинное имя папки"
         Case Else
             message = "Непредвиденная ошибка создания папки"
         End Select
      List1.AddItem (DirPath & "  " & message)
     Next i
     Label1.Caption = "Создано: " & m & " папок"
End Sub
 
Private Sub Form_Load()
Text1.Text = "c:\W\Q\A"
End Sub

' Проверка существования каталога
Public Function IsDir(FileName As String) As Boolean
    On Error Resume Next
    Dim DirAttr As Long
    
    If FileName <> vbNullString Then
        If Right(FileName, 1) = "\" Then
            FileName = Mid(FileName, 1, Len(FileName) - 1) ' Убрать на конце косую черту, если есть
        End If
        
        If Dir(FileName, vbDirectory + 7) <> vbNullString Then
            DirAttr = GetAttr(FileName)
            
            If (DirAttr And vbDirectory) <> 0 Then ' Если бит vbDirectory установлен, тогда...
                IsDir = True
            End If
        Else
            IsDir = False
        End If
    End If
    
    Err.Clear
End Function

Private Sub Form_Load()
Set ws = DBEngine.CreateWorkspace("MyWS", "admin", "")
Set db = ws.OpenDatabase("D:\путь\БД.mdb или .accdb")
Set rs = db.OpenRecordset("Sale", dbOpenDynaset)
MaxCount = 0
loadRecord
End Sub

Private Sub cmdExportExcel_Click()
Dim excelapp As Excel.Application
Dim book As Excel.Workbook
Set excelapp = New Excel.Application
excelapp.Workbooks.Add
Set book = excelapp.ActiveWorkbook
Do Until rs.EOF
Counter = Counter + 1
book.ActiveSheet.Range("a" & Counter).FormulaR1C1 = rs!tip
book.ActiveSheet.Range("b" & Counter).FormulaR1C1 = rs!Name
book.ActiveSheet.Range("c" & Counter).FormulaR1C1 = rs!Scale
book.ActiveSheet.Range("d" & Counter).FormulaR1C1 = rs!Address
book.ActiveSheet.Range("e" & Counter).FormulaR1C1 = rs!prise
book.ActiveSheet.Range("f" & Counter).FormulaR1C1 = rs!datep
book.ActiveSheet.Range("g" & Counter).FormulaR1C1 = rs!buyname
book.ActiveSheet.Range("h" & Counter).FormulaR1C1 = rs!garantyear
book.ActiveSheet.Range("i" & Counter).FormulaR1C1 = rs!Notes
rs.MoveNext
Loop
excelapp.Visible = True
Set excelapp = Nothing
loadRecord
 
End Sub

Private Sub cmdExportTXT_Click()
Dim Af As Scripting.FileSystemObject
Dim txt As Scripting.TextStream
Dim Counter As Long
Set fs = New Scripting.FileSystemObject
Set txt = fs.OpenTextFile("F:\Универ\Базы данных\Visual Basic 6.0\Учет продаж компьютеров\sale2000.txt", ForWriting, True)
Do Until rs.EOF
txt.Write rs!tip & vbTab
txt.Write rs!Name & vbTab
txt.Write rs!Scale & vbTab
txt.Write rs!Address & vbTab
txt.Write rs!prise & vbTab
txt.Write rs!datep & vbTab
txt.Write rs!buyname & vbTab
txt.Write rs!garantyear & vbTab
txt.Write rs!Notes & vbCrLf
Counter = Counter + 1
rs.MoveNext
Loop
txt.Close
Set txt = Nothing
Set fs = Nothing
loadRecord
MsgBox "Вывод данных в текстовый файл закончен.", vbInformation, "Экспорт"
End Sub