'••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
' Cоздать указанное число копий/пустышек для каждого выбранного элемента
' с добавлением счётчика после базового имени, начиная с последнего номера
' Параметры: %WL "<путь назначения>" <число копий> <вставка до №> <расширение нового файла>
' Если указан 5-й параметр, то создаваться будут пустые элементы
' Примеры: %WL "%P" | %WL "%T" 3 | %WL "%P" 5 _v | %WL "%T" 1 "" txt
'••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••• Автор: Flasher © •••
Option Explicit: Dim C, List, Path, Count, Px, Ext, ShA, FSO
Dim Rgx, F, FN, Test, Ex, BN, Max, i, n, M, Items, Exist, FP
With WSH.Arguments
C = .Count : 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 : FP = FSO.BuildPath(Path, FN)
Exist = Not (FSO.FolderExists(FP) Or FSO.FileExists(FP)) And Not Rgx.Test(BN)
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
FP = i : If Test = 0 Then FP = FSO.GetBaseName(i)
If Rgx.Test(FP) Then Set FN = Rgx.Execute(FP)(0) : M = FN.SubMatches(1) :_
If M > Max And FN.SubMatches(0) = Left(FN.SubMatches(0), Len(BN & Px)) Then Max = M
Next : i = 1 : If Exist Then i = 0 : Count = Count - 1
For i = i To Count
If i Then
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 : FP = FSO.BuildPath(Path, BN & Max) & Ext
ElseIf Not Rgx.Test(Max) Then Max = Max + 1
End If
If Test Then
If C = 5 Then FSO.CreateFolder FP & Ext Else FSO.GetFolder(F).Copy FP, 0
Else
If C = 5 Then FSO.CreateTextFile(FP & Ext) Else FSO.CopyFile F, FP, 0
End if
Next
Loop Until List.AtEndOfStream : CreateObject("WScript.Shell").SendKeys "^r" |