Total Commander

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

c:\new\photo.jpg
c:\new\photo3.jpg
c:\old\photo.jpg
c:\old\photo3.jpg

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

c:\new\photo01.jpg
c:\new\photo02.jpg
c:\old\photo03.jpg
c:\old\photo04.jpg

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

c:\new\photo01.jpg
c:\new\photo02.jpg
c:\old\photo01.jpg
c:\old\photo02.jpg

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

'======================================================================
' Переименование выделенных файлов по маске
'   [G]-[P]-{заданное слово}-[C]
'   где [P] - имя родительской папки,
'       [G] - имя папки на 2 уровня вверх ("дедушка"),
'       [С] - отдельный счетчик для каждого [P].
'   При этом расширение файлов не меняется.
'
' Параметры вызова из TC:
' %L
'======================================================================

Option Explicit
'======== Изменяемые параметры ========================================
' Заданное слово для маски переименования
Const GeneralWord = "picture"
' Разделитель в маске
Const Delimiter = "-"
' Разрядность счетчика в маске
Const Precision = 3
'======================================================================

Dim Mess, FSO, FileList, F, P, PF, G, Ext, NewName, NewPath
Dim Errors, Counter

SetMess
Set FSO     = CreateObject("Scripting.FileSystemObject")
Set Errors  = CreateObject("Scripting.Dictionary")
Set Counter = CreateObject("Scripting.Dictionary")
CheckParam
For Each F In Split(FSO.OpenTextFile(FileList, 1, False).ReadAll, vbNewLine)
  F = Trim(F)
  If F <> "" Then
    If FSO.FileExists(F) Then
      Ext = "." & FSO.GetExtensionName(F)
      PF  = FSO.GetParentFolderName(F)
      P   = FSO.GetBaseName(PF)
      G   = FSO.GetBaseName(FSO.GetParentFolderName(PF))
      If Not Counter.Exists(PF) Then
        Counter.Add PF, 1
      Else
        Counter(PF) = Counter(PF) + 1
      End If
      NewName = G & Delimiter & P & Delimiter & GeneralWord & Delimiter & Num(Counter(PF), Precision) & Ext
      NewPath = PF & "\" & NewName
      On Error Resume Next
      FSO.MoveFile F, NewPath
      If Err.Number > 0 Then
        Errors.Add F & "  ->  " & NewName, vbNewLine & Err.Description
      End If
      On Error GoTo 0
    End If
  End If
Next

If Errors.Count > 0 Then
  MessBox JoinErr(Errors), 2
Else
  MessBox Mess(3), 3
End If
Quit

Function Num(pC, pPrecision)
  Num = Right(String(pPrecision, "0") & pC, pPrecision)
End Function

Sub CheckParam
  If WScript.Arguments.Count = 0 Then
    MessBox Mess(1), 1
    Quit
  End If
  FileList  = WScript.Arguments(0)
  If Not FSO.FileExists(FileList) Then
    MessBox Mess(2), 1
    Quit
  End If
End Sub

Sub SetMess
  Set Mess = CreateObject("Scripting.Dictionary")
  Mess.Add 0,  "Переименование по маске"
  Mess.Add 1,  "Не указаны параметры!"
  Mess.Add 2,  "Входной параметр не является файлом!"
  Mess.Add 3,  "Операция завершена."
  Mess.Add 4,  "Операция завершена с ошибками." & vbNewLine
  Mess.Add 5,  "Невозможно выполнить переименование:" & vbNewLine
End Sub

Function JoinErr(pDic)
  Dim lKey
  For Each lKey In pDic
    JoinErr = JoinErr & vbNewLine & vbNewLine & Mess(5) & _
              lKey & pDic(lKey)
  Next
  JoinErr = Mess(4) & JoinErr
End Function

Function MessBox(pMess, pMode)
  Dim lIcon
  Select Case pMode
    Case 1 lIcon = vbCritical    + vbOKOnly
    Case 2 lIcon = vbExclamation + vbOKOnly
    Case 3 lIcon = vbInformation + vbOKOnly
  End Select
  MessBox = MsgBox(pMess, lIcon, Mess(0))
End Function

Sub Quit
  Set Counter = Nothing
  Set Errors  = Nothing
  Set FSO     = Nothing
  Wscript.Quit
End Sub