'============================= VBS =============================
' Убрать в именах папок активного каталога не первые антропонимы
' до знака - и создать в них строчные списки всех исходных имён
' Условие: Путь запуска — пустой
'===============================================================
Set Stm = CreateObject("ADODB.Stream")
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each Fd In FSO.GetFolder(FSO.GetAbsolutePathName("")).SubFolders
If InStr(Fd.Name, " -") Then
Arr = Split(Fd.Name, " -") : LName = Arr(0)
If InStr(LName, ",") Then
Fd.Name = Left(LName, InStr(LName, ",") - 1) & " -" & Arr(1)
With Stm
.Open : .Type = 2 : .CharSet = "UTF-8" : .WriteText Arr(0)
.SaveToFile Fd.Path & "\actors.txt", 2 : .Close
End With
End If
Else Errs = Errs & vbCr & Fd.Name
End If
Next
Set Stm = Nothing : Set FSO = Nothing
MsgBox Space(16) & "Выполнено!" & Errs, 4160,_
" Переименовать папки и создать в них списки " |