Total Commander

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

'=======================================================================
' Копировать с переименованием по счётчику и добавочным расширением
' Параметры: %WL "<путь получателя>" <вставка перед №> <доп. расширение>
'=======================================================================
With WScript.Arguments
  C = .Count : If C = 0 Then WScript.Quit
  If C <> 4 Then MsgBox "Следует указать 4 параметра!", 48,_
  Space(12) & "Ошибка вводных данных" : WScript.Quit : End If
  List = .Item(0) : P = .Item(1) : S1 = .Item(2) : S2 = .Item(3)
End With

With CreateObject("Scripting.FileSystemObject")
  Path = .BuildPath(P, "\")
  Set List = .OpenTextFile(List,,,-1)
  Do : F = List.ReadLine
    If .FileExists(F) Then
      BN = .GetBaseName(F) : Ext = "." & .GetExtensionName(F)
      If Ext = "." & S2 Then
        Ext = "." & .GetExtensionName(BN) : Test = InStrRev(BN, S1)
        If Ext <> "." Then
          If Test Then BN = Left(.GetBaseName(BN), Test - 1)
        Else Ext = ""
          If Test And IsNumeric(Mid(BN, Test + Len(S1))) Then _
          BN = Left(.GetBaseName(BN), Test - 1)
        End If
      End If : F1 = Path & BN & S1 : S = Ext & "." & S2 : i = 1
      While .FileExists(F1 & i & S) : i = i + 1 : Wend
      .CopyFile F, F1 & i & S
    Else
      F1 = Path & .GetFileName(F) & S1 : i = 1
      While .FolderExists(F1 & i & "." & S2) : i = i + 1 : Wend
      .GetFolder(F).Copy F1 & i & "." & S2
    End If
  Loop Until List.AtEndOfStream
End With : 'CreateObject("WScript.Shell").SendKeys "^R"

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

Имена выбранных файлов          Результаты
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯          ¯¯¯¯¯¯¯¯¯¯
Name.ext                        Name<префикс>№+1.ext.<постфикс>
Name.ext.<постфикс>             Name<префикс>№+1.ext.<постфикс>
Name<префикс>№.ext.<постфикс>   Name<префикс>№+1.ext.<постфикс>

Для папок - без заморочек:
Name                            Name<префикс>№+1.<постфикс>

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

'•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
' Cоздать копии с добавочным расширением для выбранных элементов
' с добавлением счётчика в скобках, начиная с последнего номера

' Параметры: %WL "<путь назначения>" <расширение копии>
' Примеры:   %WL "%P"   |   %WL "%T" old
'••••••••••••••••••••••••••••••••••••••••• Автор - Flasher © •••

Option Explicit: Dim C, List, Reg, Path, Ext, ShA,_
FSO, F, Test, Filt, M, Items, Cnt, Max, T, x, i, FN

With WScript.Arguments
  C = .Count : Ext = ".bak" : If C = 0 Then WScript.Quit
  If C = 1 Then MsgBox "Должно быть указано " & vbCr & _
  "не менее 2-х параметров!",48, " BackUp": WScript.Quit
  List = .Item(0)  : Path = .Item(1)
  If C = 3 Then Ext = "." & .Item(2)
End With: Set ShA = CreateObject("Shell.Application")
Set FSO  = CreateObject("Scripting.FileSystemObject")
Set List = FSO.OpenTextFile(List,,,-1)
Set Reg  = New Regexp
Reg.Pattern = "(.*" & Ext & ") \((\d+)\)$"
Path = FSO.BuildPath(Path, "\")

Do : F = Trim(List.ReadLine)
  If F <> "" Then
    FN = FSO.GetFileName(F) : Max = 0
    If Right(FN, Len(Ext)) = Ext Then T = 1
    If Reg.Test(FN) Then
      With Reg.Execute(FN)(0) FN = .Submatches(0):_
      Max = CLng(.Submatches(1)) End With : T = 1
    End If
    If T <> 1 Then
      FN = FN & Ext : If FSO.FileExists(Path & FN) Or _
      FSO.FolderExists(Path & FN) Then T = 1
    End If
    If FSO.FolderExists(F) Then
         Test = 1 : Filt = 73888
    Else Test = 0 : Filt = 73920 End If
    If T = 1 Then
      Set Items = ShA.NameSpace(Path).Items
      Items.Filter Filt, FN & " (*)"
      Cnt = Items.Count
      If Cnt Then
        For x = 0 To Cnt - 1
          M = Items.Item(x) : If Reg.Test(M) Then _
          M = CLng(Reg.Execute(M)(0).Submatches(1)):_
          If M > Max Then Max = M
        Next : FN = FN & " (" & Max + 1 & ")"
      Else FN = FN & " (1)" End If
    End If : FN = FSO.BuildPath(Path, FN)
    If Test Then FSO.GetFolder(F).Copy FN, 0 Else FSO.CopyFile F, FN, 0
  End If
Loop Until List.AtEndOfStream