Нужен скрипт копирующий название всех папок в папке в txt

[obuhov4]

Помогите ребят, есть папка с 1000 подпапок , вот мне нужен скрипт который бы автоматически скопировал бы название всех папок в столбик в текстовый файл *list.txt

[Monarch-LFV]

obuhov4

Код: Выделить всё

' Создает файл-список всех папок и подпапок в выделенных директориях 
' Параметр %WL
'=======================================================================================
On Error Resume Next
Dim FSO, spisok, List, F, subfolder, FldList, newLine
Set FSO = CreateObject("Scripting.FileSystemObject")
spisok = "C:\List.txt" 
List = Split(FSO.OpenTextFile(WScript.Arguments(0),,,-1).ReadAll, vbNewLine)

For Each F In List
  If FSO.FolderExists(F) Then processDir(FSO.GetFolder(F))
Next 

If FldList <> "" then 
  Set ts = FSO.OpenTextFile(spisok, 2, True, -1)
    ts.Write FldList
  ts.Close
end if

Sub processDir(Object)
  if FldList <> "" then newLine = vbnewline 
  FldList = FldList & newLine & FSO.GetFolder(Object).name
	For Each subfolder in Object.SubFolders
    processDir(subfolder)
	Next
End Sub

Код скрипта скопировать в файл script.VBS, этот файл поместить на панель кнопок и в параметрах указать %WL. Ну и если нужно указать свой путь сохранения файла в переменной spisok.

Добавлено спустя 59 минут:

Перечитал еще раз запрос, конечно же нужны уточнения, но мне кажется, что перемудрил в скрипте выше, список папок создается с рекурсией, то есть со всеми подпапками разной степени вложенности (надо ли было?).
Подумал, что все-таки нужен скрипт, который просто создает список папок в той же директории, где находимся, и только тех папок, которые расположены на данном уровне (без вложенности), то вот код:

Код: Выделить всё

' Создает файл-список всех папок в данной директории 
' Параметр "%P"
'=======================================================================================
On Error Resume Next
Dim FSO, spisok, F, FldList, newLine
Set FSO = CreateObject("Scripting.FileSystemObject")
spisok = WScript.Arguments(0) & "\List.txt" 

For Each F In FSO.GetFolder(WScript.Arguments(0)).subfolders
  If FSO.FolderExists(F) Then 
    if FldList <> "" then newLine = vbnewline 
    FldList = FldList & newLine & GetFolder(F).name
  end if
Next 

If FldList <> "" then 
  Set ts = FSO.OpenTextFile(spisok, 2, True, -1)
    ts.Write FldList
  ts.Close
end if

Обратить внимание на параметр: "%P" (в кавычках).

[Monarch-LFV]

По предложению откорректировал свой второй скрипт (действительно, проверка существования подпапки не нужна, так как итак имеется указание пробега циклом каждой подпапки, исключил ее):

Код: Выделить всё

' Создает файл-список всех папок в данной директории
' Параметр "%P"
'=======================================================================================
On Error Resume Next
Dim FSO, spisok, F, FldList, newLine, ts
Set FSO = CreateObject("Scripting.FileSystemObject")
spisok = WScript.Arguments(0) & "\List.txt"

For Each F In FSO.GetFolder(WScript.Arguments(0)).subfolders
  if FldList <> "" then newLine = vbnewline
  FldList = FldList & newLine & F.name
Next

If FldList <> "" then
  Set ts = FSO.OpenTextFile(spisok, 2, True, -1)
    ts.Write FldList
  ts.Close
end if

Также выкладываю не свою, но очень даже рабочую кнопку cmd (с помощью команды DIR создает такой файл-список моментально, в отличие от скрипта VBS, но создается в UTF-16 без BOM, а также появляется последняя пустая строка):

Код: Выделить всё

TOTALCMD#BAR#DATA
%comspec% /q/u/c dir/ad/b>Dirs.txt

%commander_exe%,24
Копировать имена всех подпапок папки активной панели в Dirs.txt

1