Total Commander

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

'======================================================================
' Для каждой из папок из файла-списка очищаются вложенные папки:
' файлы перемещаются в верхнюю папку (папка из файла-списка).
' При совпадении имён файлов выполняется автоматическое переименование.
' После выполнения переноса очищенные папки удаляются.
'
' Параметры:
' {файл-список}
'
' Пример параметров при вызове из TC:
' %L
'======================================================================
Option Explicit
Dim FSO, FF, F, SF

With WScript
  If .Arguments.Count = 0 Then
    MsgBox "Не заданы параметры!", vbOKOnly + vbCritical, "Очистка вложенных папок"
    .Quit
  End If
  FF = .Arguments(0)
End With

Set FSO = CreateObject("Scripting.FileSystemObject")

With FSO.OpenTextFile(FF, 1)
  Do While Not .AtEndOfStream
    F = Trim(.ReadLine)
    If F <> "" Then
      If FSO.FolderExists(F) Then
        For Each SF In FSO.GetFolder(F).SubFolders
          On Error Resume Next 
          MoveFromFolder SF, F
          If Err.Number = 0 Then FSO.DeleteFolder SF.Path
          Err.Clear
          On Error GoTo 0
        Next
      End If
    End If
  Loop
  .Close
End With

Set FSO = Nothing
WScript.Quit

Sub MoveFromFolder(pSubFolder, pFolder)
  Dim lF
  For Each lF In pSubFolder.Files
    MoveFile lF, pFolder
  Next
  For Each lF In pSubFolder.SubFolders
    MoveFromFolder lF, pFolder
    FSO.DeleteFolder lF.Path
  Next
End Sub

Sub MoveFile(pFile, pFolder)
  Dim lF
  lF = pFolder
  If Right(lF, 1) <> "" Then lF = lF & ""
  lF = NextName(lF & pFile.Name)
  FSO.MoveFile pFile.Path, lF
End Sub

Function NextName(pFilePath)
  Dim lPath, lName, lExt, li, lAdd
  Const lQ = 1 'Минимальное количество цифр в номере
  With CreateObject("Scripting.FileSystemObject")
    lPath = .GetParentFolderName(pFilePath)
    If lPath <> "" Then lPath = lPath & ""
    lName    = .GetBaseName(pFilePath)
    lExt     = .GetExtensionName(pFilePath)
    NextName = pFilePath
    Do While .FileExists(NextName)
      li = li + 1
      If li < 10^lQ Then
        lAdd = Right(String(lQ, "0") & li, lQ)
      Else
        lAdd = li
      End If
      NextName = lPath & lName & "(" & lAdd & ")." & lExt
    Loop
  End With
End Function

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

H:\1\CLARA-HU1-B-004\Video\CLARA-HU1-B-004-1280x720
H:\1\CLARA-HU1-B-004\Video\CLARA-HU1-B-004_video_640x368

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

CLARA-HU1-B-004-1280x720 и CLARA-HU1-B-004_video_640x368

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

папка1\1\удаляемая папка\

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

папка1\1\

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

With FSO.OpenTextFile(FF, 1)
  Do While Not .AtEndOfStream
    If F <> "" Then
      If FSO.FolderExists(F) Then
      Set F = .GetFolder(.ReadLine)
        For Each SF In F.SubFolders
          On Error Resume Next
          MoveFromFolder SF, F
          If Err.Number = 0 Then FSO.DeleteFolder SF.Path
          Err.Clear
          On Error GoTo 0
        Next
      If F.Size = 0 Then F.Delete
      End If
    End If
  Loop
  .Close
End With