'============================= 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,_
" Переименовать папки и создать в них списки       "