Total Commander

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

'=====================================================================
' Перемещение выделенных файлов\папок в соответствующие им папки на
'   противоположной панели TC

' Параметры вызова из TC:
' %L "%T"
'=====================================================================
Option Explicit
Dim EF
Set EF = CreateObject("Scripting.Dictionary")
'========== Изменяемые параметры =====================================
'Массив соответствия, задаваемый регулярными выражениями
EF.Add "^[\dA-Za-z].*$", "0-9-A-Z"
EF.Add "^([А-Яа-я]).*$", "$1"
'=====================================================================

Dim Title, Mess, FSO, ListF, List, Target, Fold, File, NewPath, REx, K, M, i
' Проверяем параметры
Title = "Внимание!"

If WScript.Arguments.Count < 2 Then
  Mess = "Неправильно указаны параметры!"
  MessQuit
End If

Set FSO = CreateObject("Scripting.FileSystemObject")
ListF   = WScript.Arguments(0)
Target  = WScript.Arguments(1)
If Right(Target, 1) <> "" Then Target = Target & ""

If Not FSO.FileExists(ListF) Then
  Mess = "Неправильно указан файл-список обрабатываемых файлов!"
  MessQuit
End If

If Not FSO.FolderExists(Target) Then
  Mess = "Неправильно указана целевая папка!"
  MessQuit
End If

Set REx = New RegExp
List = Split(FSO.OpenTextFile(ListF).ReadAll, vbNewLine)
For Each File In List
  Fold = ""
  If File <> "" Then
    For Each K In EF.Keys
      REx.Pattern = K
      If REx.Test(FSO.GetFileName(File)) Then
        Fold = REx.Replace(FSO.GetFileName(File), EF(K))
        Exit For
      End If
    Next
    If Fold <> "" Then
      Fold = Target & Fold & ""
      If FSO.FolderExists(Fold) Then
        NewPath = NextName(Fold & FSO.GetFileName(File))
        If FSO.FileExists  (File) Then FSO.MoveFile   File, NewPath
        If FSO.FolderExists(File) Then
          If Right(File, 1) = "" Then File = Mid(File, 1, Len(File) - 1)
          FSO.MoveFolder File, NewPath
        End If
      End If
    End If
  End If
Next

MsgBox "Выполнено!", vbOKOnly + vbInformation, "Результат"
Quit

Function NextName(pPath)
  Dim lPath, lName, lExt, li, lAdd
  Const lQ = 1 'Минимальное количество цифр в номере
  With CreateObject("Scripting.FileSystemObject")
    lPath = .GetParentFolderName(pPath)
    If lPath <> "" Then lPath = lPath & ""
    lName    = .GetBaseName(pPath)
    lExt     = .GetExtensionName(pPath)
    NextName = pPath
    Do While .FileExists(NextName) Or .FolderExists(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

Sub MessQuit
  MsgBox Mess, vbOKOnly + vbError, Title
  Quit
End Sub

Sub Quit
  Set FSO = Nothing
  Wscript.Quit
End Sub