[cut="Обновка. Не знаю, актуально ли. Но всё-равно кому-то может пригодится."]
Код: Выделить всё
'••••••••••••••••••••••••••••••••••••••••••• VBS ••••••••••••••••••••••••••••••••••••••••••
' Cоздать указанное число копий/пустышек для каждого выбранного элемента
' с добавлением счётчика после базового имени, начиная с последнего номера
' Параметры: %WL "<путь назначения>" <число копий> <вставка до №> <расширение нового файла>
' Если указан 5-й параметр, то создаваться будут пустые элементы
' Ключ для смены начала счётчика с единицы на двойку: /2
' Примеры: %WL "%P" /2 | %WL "%T" 3 | %WL "%P" 5 _v | %WL "%T" 1 "" txt
'••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••• Автор: Flasher © •••
Option Explicit : Dim C, Two, List, Cn, Path, Count, Px, Ext, ShA, FSO, Rgx
Dim F, FN, Test, Ex, BN, Max, i, n, M, Items, FF, Exist, FP, Cnt, Num, Check
With WSH.Arguments
C = .UnNamed.Count : Two = .Named.Exists("2") : If C = 0 Then WSH.Quit
If C = 1 Then MsgBox "Должно быть указано не менее 2-х параметров!", 48 : WSH.Quit
List = .Item(0) : Path = .Item(1) : If C > 2 Then Count = .Item(2)
If Count = "" Then Count = Trim(InputBox(String(4, vbLf) & "Введите число создаваемых копий"&_
vbLf & "для каждого выбранного элемента:", Space(13) & "Создание копий выбранных элементов"))
If Not IsNumeric(Count) Then WSH.Quit : End If : If C > 3 Then Px = .Item(3)
If C = 5 Then If .Item(4) <> "" Then Ext = "." & .Item(4) End If
End With : Set Rgx = New RegExp : Rgx.Pattern = "^(.*\D)?((0*)\d+)$"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ShA = CreateObject("Shell.Application")
Set List = FSO.OpenTextFile(List,,,-1)
Do : F = Trim(List.ReadLine)
FN = FSO.GetFileName(F)
If FSO.FolderExists(F) Then
Test = 1 : BN = FN
ElseIf FSO.FileExists(F) Then
Test = 0 : BN = FSO.GetBaseName(FN)
Ex = FSO.GetExtensionName(F) : If C < 5 And Len(Ex) Then Ext = "." & Ex
End If : Max = 0 : If C = 5 Then FN = FSO.GetBaseName(F) & Ext
FP = FSO.BuildPath(Path, FN) : Exist = (FSO.FolderExists(FP) Or FSO.FileExists(FP))
If Rgx.Test(BN) Then
M = Rgx.Execute(BN)(0).SubMatches(1) : Max = M : BN = Left(BN, Len(BN) - Len(M))
ElseIf Right(BN, Len(Px)) <> Px Then
n = 1
For i = 1 To Len(Px)
If Left(Px, i) = Right(BN, i) Then n = i
Next : BN = BN & Mid(Px, n)
End If : Set Items = ShA.NameSpace(Path).Items
Items.Filter 73952, BN & "*" & Ext
For Each i in Items
If Test = 0 Then FF = FSO.GetBaseName(i.Path) Else FF = FSO.GetFileName(i.Path)
If Replace(Ext, ".", "") = FSO.GetExtensionName(i.Path) Then _
If Rgx.Test(FF) Then Set FN = Rgx.Execute(FF)(0) : M = FN.SubMatches(1) :_
If CLng(M) > CLng(Max) And FN.SubMatches(0) = Left(FN.SubMatches(0), Len(BN & Px)) Then Max = M
Next : Cnt = Count
If Not Exist Then Create Test, F, FP, Ext : Cnt = Count - 1
If Cnt Then
For i = 1 To Cnt
If Rgx.Execute(Max)(0).SubMatches(2) = "" Then
Max = Max + 1
Else
If Len(Max + 1) >= Len(Max) Then Max = Max + 1 Else _
Max = String(Len(Max) - Len(Max + 1), "0") & Max + 1
End If : If Two And Max < 2 Then Max = 2
FP = FSO.BuildPath(Path, BN & Max) & Ext
Create Test, F, FP, Ext
Next
End If
Loop Until List.AtEndOfStream : CreateObject("WScript.Shell").SendKeys "^r"
Sub Create(T, Fl, PF, E)
If T Then
If C = 5 Then FSO.CreateFolder PF Else FSO.GetFolder(Fl).Copy PF, 0
Else
If C = 5 Then FSO.CreateTextFile PF Else FSO.CopyFile Fl, PF, 0
End if
End Sub
.
