Total Commander

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

'======================================================================
' Перемещать файлы и папки, указанные в файлах-списках
' в папки с базовыми именами этих файлов-списков
' Параметры: %L <путь_назначения\>
' Пример: %L "%T"
'======================================================================
L = vbNewLine
D = InputBox(L&L&L&"Введите число отсекаемых компонентов " & L &_
"в началах путей, записанных" & L & "в выделенные файлы :",_
Space(13) & "Перемещение файлов и папок по спискам") 
If Trim(D) = "" Or Not IsNumeric(D) Then Wscript.Quit

With CreateObject("Scripting.FileSystemObject")
  Set TF = .OpenTextFile(WScript.Arguments(0), 1)
  Do While Not TF.AtEndOfStream
    F = TF.ReadLine
    If F > vbNullString And .FileExists(F) Then
      Trg = WScript.Arguments(1) & .GetBaseName(F)
      If Not .FolderExists(Trg) Then .CreateFolder Trg
      For Each Fn in Split(.OpenTextFile(F, 1).ReadAll, vbNewLine)
        Fn = Trim(Fn)
        If Fn <> "" And Mid(Fn, 2, 1) = ":" Then
          Fx = Fn
          Do While Abs(D) =< Abs(Ubound(Split(Fx, "\")))
            Fx = .GetParentFolderName(Fx)
          Loop
          FPath = Trg & "\" & .GetParentFolderName(Mid(Fn, Len(Fx)+2))
          If Not .FolderExists(FPath) Then .CreateFolder FPath
          If .FolderExists(Fn) Then .GetFolder(Fn).Move FPath & "\"
          If .FileExists(Fn) Then .GetFile(Fn).Move FPath & "\"
        End If
      Next
    End If
  Loop
  TF.Close
End With

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

'=====================================================================
' Создание папки по имени файла-списка и перемещение в нее файлов
' из файла-списка с родительской папкой.

' Параметры:
' {файл-список} {целевая папка}
'=====================================================================
Option Explicit
Dim FSO, FileList, TargetDir, F, FF

If WScript.Arguments.Count = 0 Then
  MsgBox "Не указаны параметры!", vbOKOnly + vbError, "Внимание!"
  Wscript.Quit
End If

FileList  = WScript.Arguments(0)
TargetDir = WScript.Arguments(1)
If Right(TargetDir, 1) <> "\" Then TargetDir = TargetDir & "\"
Set FSO   = CreateObject("Scripting.FileSystemObject")
TargetDir = TargetDir & FSO.GetBaseName(FileList) & "\"

With FSO.OpenTextFile(FileList, 1)
  Do While Not .AtEndOfStream
    F = Trim(.ReadLine)
    If F <> "" And FSO.FileExists(F) Then
      FF = TargetDir & FSO.GetFileName(FSO.GetParentFolderName(F)) & "\"
      CreateFolder FF
      FSO.MoveFile F, FF
    End If
  Loop
  .Close
End With

MsgBox "Выполнено!", vbOKOnly + vbInformation, "Результат"
Set FSO = Nothing
Wscript.Quit

Sub CreateFolder(pFolder)
  Dim lParentFolder
  If Not FSO.FolderExists(pFolder) Then
    lParentFolder = FSO.GetParentFolderName(pFolder)
    If Not FSO.FolderExists(lParentFolder) Then CreateFolder(lParentFolder)
    FSO.CreateFolder(pFolder)
  End If
End Sub