Ещё раз о сортировки VBS скриптами
Первый скрипт делает :
Запущенный в директории с папками с субпапками второго уровня переименовывает субпапки по принципу "Основная папка - субпапка второго уровня " и складывает в папку конечные, т.е. имея папку "Война и мир" лежащую в папке "Лев Толстой" перемещаем папку "Война и мир" в папку "Конечные" переименовав на ходу в "Лев Толстой - Война и мир". После отработки бибикает.
Второй (новый) скрипт делает :
Запущенный в директории с папками переименовывает файлы в них по принципу "Основная папка - имя файла старое " и складывает в папку конечные, т.е. имея папку "Война и мир" лежащую в файл "Лев Толстой" перемещаем файл "Война и мир" в папку "Конечные" переименовав на ходу в "Лев Толстой - Война и мир". После отработки бибикает.
Копируем текст в блокнотике и сохраняем Имя_скрипта.vbs
ПЕРВЫЙ СКРИПТ :
Dim FSO, Folder, List, List2, Folder2, Papka
Set FSO = CreateObject("Scripting.FileSystemObject")
Set F = FSO.GetFile(Wscript.ScriptFullName)
path = FSO.GetParentFolderName(F)
REM Отключаем сообщения об ошибке - если папка "Конечная" уже есть
On Error Resume Next
REM Создание в дирректории с скриптом папки "Конечная"
fso.createfolder path & "\" & "Конечная"
Set Folder = FSO.GetFolder(path)
REM Цикл перечисление папок в директории
For Each Papka In Folder.SubFolders
List1 = Papka.Name
REM Присвоение path2 пути к папке в цикле
path2= path & "\" & List1
Set Folder2 = FSO.GetFolder(path2)
For Each Papka2 In Folder2.SubFolders
REM Цикл перечисление папок в субдиректориях
List2 = Papka2.Name
REM Присвоение File1 пути к субпапке
File1 = path2 & "\" & List2
REM Исключение из обработки папки "Конечная" чтоб в ней подпапки не имели в имени название этой папки
if List1<>"Конечная" then
File2 = List1 & " - " & List2
else
File2 = List2
end if
REM Переименование через CMD
Dim Ws,Command,Execution
Set Ws = CreateObject("WScript.Shell")
Command = "Cmd /c Ren "& DblQuote(File1) &" "& DblQuote(File2) &""
Execution = Ws.Run(Command,0,False)
Wscript.Sleep(200)
REM Расчет путей и перемещение папок в папку "Конечная"
File3 = path2 & "\" & File2
File4 = path & "\" & "Конечная\"
FSO.MoveFolder File3 , File4
Next
Wscript.Sleep(200)
File5 = path & "\" & "Конечная"
REM В конце удаляем папки исходные уже без подпапок и исключаем из стирания папку "Конечная"
if path2<>File5 then
FSO.DeleteFolder path2 , False
End If
Next
REM БИБИКАЕМ когда закончили обработку
set wshShell = Wscript.CreateObject("wscript.Shell")
beep = chr(007)
WshShell.Run "cmd /c @Echo " & beep, 0
WshShell.Run "cmd /c @Echo " & beep, 0
WshShell.Run "cmd /c @Echo " & beep, 0
WshShell.Run "cmd /c @Echo " & beep, 0
WshShell.Run "cmd /c @Echo " & beep, 0
WshShell.Run "cmd /c @Echo " & beep, 0
WshShell.Run "cmd /c @Echo " & beep, 0
REM НЕ ТРОГАТЬ ! Это субскрипт для переименования папок
'**********************************************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************
ВТОРОЙ СКРИПТ:
Dim FSO, Folder, List, List2, Folder2, Papka
Set FSO = CreateObject("Scripting.FileSystemObject")
Set F = FSO.GetFile(Wscript.ScriptFullName)
path = FSO.GetParentFolderName(F)
REM Отключаем сообщения об ошибке - если папка "Конечная" уже есть
On Error Resume Next
REM Создание в дирректории с скриптом папки "Конечная"
fso.createfolder path & "\" & "Конечная"
Set Folder = FSO.GetFolder(path)
REM Цикл перечисление папок в директории
For Each Papka In Folder.SubFolders
List1 = Papka.Name
REM Присвоение path2 пути к папке в цикле
path2= path & "\" & List1
Set Folder2 = FSO.GetFolder(path2)
For Each Papka2 In Folder2.Files
REM Цикл перечисление ФАЙЛОВ В СУБПАПКАХ
List2 = Papka2.Name
REM Присвоение File1 пути к ФАЙЛУ В СУБПАПКЕ
File1 = path2 & "\" & List2
REM Исключение из обработки папки "Конечная" чтоб в ней подпапки не имели в имени название этой папки
if List1<>"Конечная" then
File2 = List1 & " - " & List2
else
File2 = List2
end if
REM Переименование через CMD
Dim Ws,Command,Execution
Set Ws = CreateObject("WScript.Shell")
Command = "Cmd /c Ren "& DblQuote(File1) &" "& DblQuote(File2) &""
Execution = Ws.Run(Command,0,False)
Wscript.Sleep(200)
REM Расчет путей и перемещение папок в папку "Конечная"
File3 = path2 & "\" & File2
File4 = path & "\" & "Конечная\"
FSO.MoveFile File3 , File4
Next
Wscript.Sleep(200)
File5 = path & "\" & "Конечная"
REM В конце удаляем папки исходные уже без подпапок и исключаем из стирания папку "Конечная"
if path2<>File5 then
FSO.DeleteFolder path2 , False
End If
Next
REM БИБИКАЕМ когда закончили обработку
set wshShell = Wscript.CreateObject("wscript.Shell")
beep = chr(007)
WshShell.Run "cmd /c @Echo " & beep, 0
WshShell.Run "cmd /c @Echo " & beep, 0
WshShell.Run "cmd /c @Echo " & beep, 0
WshShell.Run "cmd /c @Echo " & beep, 0
WshShell.Run "cmd /c @Echo " & beep, 0
WshShell.Run "cmd /c @Echo " & beep, 0
WshShell.Run "cmd /c @Echo " & beep, 0
REM НЕ ТРОГАТЬ ! Это субскрипт для переименования папок
'**********************************************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************