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

Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
    ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
    (ByVal idHook As Long, ByVal lpfn As Long, ByVal hMod As Long, ByVal dwThreadID As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
(ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam 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 Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SysAllocString Lib "oleaut32.dll" (ByRef pOlechar As Byte) As String
Private Declare Function SysAllocStringByteLenLng Lib "oleaut32" Alias "SysAllocStringByteLen" (ByVal psz As Long, ByVal cbLen As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
'Private Declare Function SysAllocStringByteLenStr Lib "oleaut32" Alias "SysAllocStringByteLen" (ByVal ptr As Long, ByVal Length As Long) As String
Private Declare Function SysAllocStringByteLen Lib "oleaut32.dll" (Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As String
'Private Declare Function lstrlenA Lib "kernel32.dll" (ByVal lpString As String) As Long
Private Declare Function lstrlenA Lib "kernel32.dll" (ByVal lpString As Long) As Long
 
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5           'Система собирается активизировать окно
Private Const HCBT_CREATEWND As Long = 3  'Окно собирается создаваться. Система вызывает процедуру фильтра (hook) перед отправкой в окно сообщения WM_CREATE или WM_NCCREATE. Если процедура фильтра (hook) возвращает ненулевое значение, система уничтожает окно; функция CreateWindow возвращает значение  ПУСТО (NULL), но сообщение WM_DESTROY не отправляется в окно. Если процедура фильтра (hook) возвращает значение нуль, окно создается как обычно.
Private Const HCBT_DESTROYWND As Long = 4 'Окно собирается разрушаться.
Private Const HCBT_MINMAX As Long = 1     'Окно собирается быть свернутым или развернутым.
Private Const HCBT_MOVESIZE As Long = 0   'Окно собирается перемещаться или изменить размер.
Private Const HC_ACTION = 0
 
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_LBUTTONUP As Long = &H202
 
Private Type CREATESTRUCT
  lpCreateParams As Long
  hInstance As Long
  hMenu As Long
  hwndParent As Long
  cy As Long
  cx As Long
  y As Long
  x As Long
  Style As Long
  lpszName As Long ' As String
  lpszClass As Long ' As String
  ExStyle As Long
End Type
 
Private Type CBT_CREATEWND
  lpcs As Long ' As CREATESTRUCT
  hwndInsertAfter As Long
End Type
 
Type UNICODE_STRING
    Length As Integer
    MaximumLength As Integer
    Buffer As Long
End Type
 
Private hHook As Long
 
Private Sub Form_Load()
    Dim s1 As String
    Dim s2 As String
    Dim p1 As Long
 
    s1 = StrConv("dsdfasdf", vbFromUnicode) ' Create an ANSI string.
    p1 = StrPtr(s1)
    s2 = StrFromAnsiPtr(p1)
    MsgBox s2
 
 
'    s1 = "dsdfasdf"
'    p1 = StrPtr(s1)
'    s2 = StrFromUniPtr(p1)
'    MsgBox s2
 
 
End Sub
 
Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim RetVal&, crWnd As CBT_CREATEWND, crStr As CREATESTRUCT, s$, us As UNICODE_STRING
    Dim strClassName As String, lngBuffer As Long, i&
    Dim startline&, startcolumn&, endline&, endcolumn&
    On Error Resume Next
    
    If lngCode < HC_ACTION Then
        NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
        Debug.Print NewProc
        Exit Function
    End If
 
    className$ = String$(256, " ")
    lngBuffer& = 255
    windTitle$ = String$(256, " ")
    
    Select Case lngCode
      Case HCBT_CREATEWND
        RetVal = GetClassName(wParam, className, lngBuffer)
        className = Left$(className, RetVal)
        If className = "Net UI Tool Window" Then
            i = i + 1
            If i = 2 Then NewProc = 1
        End If
'        Debug.Print "HCBT_CREATEWND"; wParam; className
        CopyMemory crWnd, ByVal lParam, LenB(crWnd)
        CopyMemory crStr, ByVal crWnd.lpcs, Len(crStr) '!!!!!
        Debug.Print className; "|  |"; SysAllocStringByteLen(crStr.lpszClass, lstrlenA(crStr.lpszClass))      
 
 
      Case HCBT_ACTIVATE
        i = 0
        RetVal = GetWindowText(wParam, windTitle, lngBuffer)
        windTitle = Left$(windTitle, RetVal)
        RetVal = GetClassName(wParam, className, lngBuffer)
        className = Left$(className, RetVal)
'        Debug.Print 1;
'        Debug.Print "HCBT_ACTIVATE"; wParam; ; className; " "; windTitle
        
        If className = "#32770" And windTitle = "Microsoft Visual Basic" Then
            DoEvents
            
        ElseIf className = "#32770" And windTitle = "Microsoft Visual Basic for Applications" Then
            DoEvents
            
        End If
        
    End Select
    CallNextHookEx hHook, lngCode, wParam, lParam
End Function
 
Sub Hook()
    Dim lngModHwnd As Long, lngThreadID As Long
    
    lngThreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)
 
    hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
    ThisWorkbook.Sheets(1).Cells(1) = hHook
End Sub
 
Sub UnHook()
    If hHook = 0 Then
        hHook = ThisWorkbook.Sheets(1).Cells(1)
    End If
    UnhookWindowsHookEx hHook
    ThisWorkbook.Sheets(1).Cells(1).Clear
End Sub
 
Sub Ошибка()
    Dim a
    a = 1 / 0
End Sub
 
Sub НеОшибка()
    MsgBox "sffafasf"
End Sub
Private Function MakeStringCopy(ByVal Ptr As Long) As String 'The trick
    GetMem4 SysAllocString(ByVal Ptr), ByVal VarPtr(MakeStringCopy)
End Function
Public Function StrFromAnsiPtr(ByVal lpStr As Long, Optional LocaleID As Long) As String
    ' Retrieves an ANSI string from memory and places it in a VB6 string (Unicode) variable.
    '
    ' This gets the string as ANSI.
    GetMem4 SysAllocStringByteLenLng(lpStr, lstrlenA(lpStr)), ByVal VarPtr(StrFromAnsiPtr)
    ' This converts it to Unicode.
    StrFromAnsiPtr = StrConv(StrFromAnsiPtr, vbUnicode) ', LocaleID)
End Function
Public Function StrFromAnsiPtr2(ByVal lpStr As Long) As String
    StrFromAnsiPtr2 = SysAllocStringByteLen(lpStr, lstrlenA(lpStr))
End Function
 
'Returns a copy of a null-terminated ANSI string (LPSTR/LPCSTR) from the given pointer
Public Function GetStrFromPtrA(ByVal Ptr As Long) As String
    GetStrFromPtrA = SysAllocStringByteLen(Ptr, lstrlenA(Ptr))
End Function