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

Private Sub Command1_Click()
Dim n As Integer, Name As String, i As Integer
On Error Resume Next
n = Int(InputBox("Введите количество папок"))
Name = InputBox("Введить путь и основное имя папки (например с:\New_Dir")
    For i = 1 To n
        MkDir Name & i
    Next
If Err Then MsgBox "Что то пошло не так": Err.Clear
End Sub

Print "Создана  " & Name & i

'This module is the standard Browse for Folder with a few changes
'to the BrowseCallbackProc function in order to locate the position
'of the buttons so our button/checkbox will line up
 
'===================================================
'Optimization - 2San    e-mail: apexsun@narod.ru
'http://apexsun.narod.ru/
'===================================================
 
Option Explicit
 
Private Const BIF_STATUSTEXT As Byte = &H4&
Private Const BIF_RETURNONLYFSDIRS As Byte = 1
Private Const BIF_DONTGOBELOWDOMAIN As Byte = 2
Private Const MAX_PATH As Integer = 260
Private Const WM_USER As Integer = &H400
Private Const BFFM_INITIALIZED As Byte = 1
Private Const BFFM_SELCHANGED As Byte = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Sub keybd_event Lib "User32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Declare Function SHCreateDirectory Lib "shell32" (ByVal hwnd As Long, ByVal pszPath As Long) As Long
Const KEYEVENTF_KEYUP As Byte = &H2
Const GW_NEXT As Byte = 2
Const GW_CHILD As Byte = 5
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Type BrowseInfo
  hwndOwner      As Long
  pIDLRoot       As Long
  pszDisplayName As Long
  lpszTitle      As Long
  ulFlags        As Long
  lpfnCallback   As Long
  lParam         As Long
  iImage         As Long
End Type
Private m_CurDir As String
'Public variables to broadcast info to other mods
Dim BFhwnd As Long 'handle of the dialog
Dim R As RECT, Bt As RECT
Dim Newboy As Boolean 'We made a new folder and are relaunching the dialog
Dim Cc As String
Dim SNB As Boolean
 
Private Declare Function CreateWindowExA Lib "user32" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal lngHandle As Long, ByVal lngMsg As Long, ByVal lngFirstParam As Long, ByVal lngLastParam As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal lngHandle As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private lngOldProc As Long
 
Public Function BrowseForFolder(ByRef StartDir As String, ByRef owner As Long, ByRef Title As String, ByRef ShowNewFoldButton As Boolean) As String
'Standard call for the dialog
  Dim lpIDList As Long
  Dim szTitle As String
  Dim sBuffer As String
  Dim tBrowseInfo As BrowseInfo
  Dim MakeDir As String
  
  SNB = ShowNewFoldButton
  m_CurDir = StartDir & vbNullChar
againplease:
  szTitle = Title
  With tBrowseInfo
    .hwndOwner = owner
    .lpszTitle = lstrcat(szTitle, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
    .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)
  End With
  lpIDList = SHBrowseForFolder(tBrowseInfo)
  If lpIDList Then
    sBuffer = Space(MAX_PATH)
    SHGetPathFromIDList lpIDList, sBuffer
    sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
  End If
    If Newboy = True Then
    'A new folder needs to be created
        Err = 0
        On Error GoTo againplease
        m_CurDir = m_CurDir + IIf(Right$(m_CurDir, 1) = "\", "", "\") + Cc & vbNullChar
        Newboy = False
        lngOldProc = 0
        
        If Cc <> "" Then
            If IsDir(SuperTrim(m_CurDir)) = False Then
                MakeDir = SuperTrim(m_CurDir)
                
                If SHCreateDirectory(0, StrPtr(MakeDir)) <> 0 Then
                    MsgBox "Ошибка создания папки!", vbExclamation
                End If
            Else
                MsgBox "Папка уже существует!", vbExclamation
            End If
        End If
        
        GoTo againplease
    End If
  If lpIDList Then
    BrowseForFolder = sBuffer
  Else
    BrowseForFolder = ""
  End If
  lngOldProc = 0
End Function
Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
Dim lpIDList As Long
Dim Ret As Long
Dim hwnda As Long, ClWind As String * 7
Dim sBuffer As String
 
On Error Resume Next
BFhwnd = hwnd
Select Case uMsg
  Case BFFM_INITIALIZED
    'If we are relaunching the dialog we want to use the existing
    'RECT to position it otherwise get new values
    If Not Newboy Then Call GetWindowRect(hwnd, R)
    With R
    Call MoveWindow(hwnd, .Left, .Top, .Right - .Left, .Bottom - .Top, True)
    End With
    Call SendMessage(hwnd, BFFM_SETSELECTION, 1, m_CurDir)
        'Lets go through all the dialogs' children till we find a Button
        hwnda = GetWindow(hwnd, GW_CHILD)
        Do While hwnda <> 0
            GetClassName hwnda, ClWind, 7
            If Left$(ClWind, 6) = "Button" Then
                Call GetWindowRect(hwnda, Bt)
                Exit Do
            End If
            hwnda = GetWindow(hwnda, GW_NEXT)
        Loop
        If lngOldProc = 0 And SNB Then
            Dim lngHandle As Long
            With Bt
            lngHandle = CreateWindowExA(0, "button", "Новая папка", &H40000000, 10, .Top - R.Top - (.Bottom - .Top) + 1, 95, .Bottom - .Top, hwnd, 0, App.hInstance, ByVal 0)
            End With
            ShowWindow lngHandle, 1
            SetProc lngHandle
        End If
  Case BFFM_SELCHANGED
    'Make the status text show the selected folder
    sBuffer = Space(MAX_PATH)
    Ret = SHGetPathFromIDList(lp, sBuffer)
    If Ret = 1 Then
      Call SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
      Ret = InStr(sBuffer, vbNullChar) - 1
      m_CurDir = Left$(sBuffer, Ret)
    End If
End Select
BrowseCallbackProc = 0
End Function
Private Function GetAddressofFunction(ByRef add As Long) As Long
  GetAddressofFunction = add
End Function
Public Sub SetProc(ByVal lngHandle As Long)
    lngOldProc = SetWindowLongA(lngHandle, -4, AddressOf WinProc)
End Sub
Private Function WinProc(ByVal lngHandle As Long, ByVal lngMsg As Long, ByVal lngFirstParam As Long, ByVal lngLastParam As Long) As Long
    Static MD As Byte
    Select Case lngMsg
    Case &H201
        MD = 1
    Case &H202
        If MD = 1 Then GoNew
        MD = 0
    Case &H200
        MD = 0
    End Select
    WinProc = CallWindowProcA(lngOldProc, lngHandle, lngMsg, lngFirstParam, lngLastParam)
End Function
 
Private Sub GoNew()
    If InStr(1, m_CurDir, vbNullChar) > 0 Then m_CurDir = Left$(m_CurDir, InStr(1, m_CurDir, vbNullChar) - 1)
    
    Cc = InputBox("Введите имя новой папки:" & vbCrLf & m_CurDir & IIf(Right$(m_CurDir, 1) = "\", "", "\"), "Создание папки")
    If Cc = "" Then Exit Sub
    
    'establish the current location of the dialog so we can
    'launch the new dialog in the same location
    'Where's the window ?
    Call GetWindowRect(BFhwnd, R)
    'Simulate the 'OK' button being pressed in order to
    'close the current dialog retrieving selected path,
    'so we can make a new folder and then relaunch the dialog
    'with the new folder as the selected initial directory
    keybd_event vbKeyEscape, 0, 0, 0
    keybd_event vbKeyEscape, 0, KEYEVENTF_KEYUP, 0
    Newboy = True
End Sub
 
' Удаляет все Chr(0) в строке
Public Function SuperTrim(StringValue As String) As String
    SuperTrim = Replace(StringValue, vbNullChar, vbNullString)
End Function
 
' Проверка существования каталога
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

Option Explicit
 
Private Sub Command1_Click()
    Me.Caption = BrowseForFolder(App.Path, hwnd, "Выбор папки для testuser2", True)
End Sub
 
Private Sub Command2_Click()
    Me.Caption = BrowseForFolder(App.Path, hwnd, "Выбор папки для testuser2", False)
End Sub

Option Explicit
 
 
Const BIF_RETURNONLYFSDIRS = &H1&
Const BIF_EDITBOX = &H10&
Const BIF_NEWDIALOGSTYLE = &H40&
Const BIF_USENEWUI = BIF_EDITBOX Or BIF_NEWDIALOGSTYLE
Const BIF_NONEWFOLDERBUTTON = &H200&
Const BIF_SHAREABLE = &H8000&
 
Private Sub Command1_Click()
    Dim Folder As Object
    
    With CreateObject("Shell.Application")
        Set Folder = .BrowseForFolder(hWnd, "Pick a folder", BIF_RETURNONLYFSDIRS _
                                                          Or BIF_SHAREABLE _
                                                          Or BIF_USENEWUI _
                                                          Or BIF_NEWDIALOGSTYLE _
                                                          Or BIF_NONEWFOLDERBUTTON)
    End With
    
    If Folder Is Nothing Then
        MsgBox "cancel"
    Else
        Me.Caption = Folder.Self.Path
    End If
End Sub

Dim Folder As Object
    
    With CreateObject("Shell.Application")
        Set Folder = .BrowseForFolder(hwnd, "Browse folder", 36) ' Значение 36 я взял из MSDN таким образом будет появляться кнопка создания папки
    End With
    
    If Folder Is Nothing Then
        MsgBox "cancel"
    Else
        Me.Caption = Folder.Self.Path
    End If
    
    Set Folder = Nothing ' Почистить объект