Копирование с автопереименованием

Материал из TCKB 2.0

Перейти к: навигация, поиск
A: Запрос на создание копий элементов с продолжением номера на конце имени файла или папки без заполнения промежутков в списке копий:
'••••••••••••••••••••••••••••••••••• VBS •••••••••••••••••••••••••••••••••••
' Cоздать указанное число копий/пустышек для каждого выделенного элемента
' с добавлением счётчика в скобках, начиная с последнего номера

' Параметры: %WL "<путь назначения>" <число копий> <расширение нового файла>
' Если указан 4-й параметр, то создаваться будут пустые элементы
' Ключ с минимальным числом секунд для оповещения об окончании: /s:<секунды>
' Ключ для расположения счётчика в конце имён копий файлов:     /end

' Примеры:   %WL "%P" 3 /s:10   |   %WL "%P" 5 txt   |   %WL "%T" 20 /end
'•••••••••••••••••••••••••••••••••••••••••••••••••••••• Автор: Flasher © •••

Option Explicit : Dim C, Cnt2End, Sec, T, List, Path, Count, Ext, ShA
Dim FSO, F, Test, Filt, BN, Ent, M, Items, Cnt, Ln, x, Item, Max, i, FN
 
With WSH.Arguments
  C = .UnNamed.Count : If C = 0 Then WSH.Quit
  Cnt2End = .Named.Exists("end") : Sec = .Named("s") : If Sec Then T = Timer
  If C < 3 Then MsgBox "Должно быть указано не менее 3-х параметров!", 48 : WSH.Quit
  List = .Item(0) : Path = .Item(1) : Count = .Item(2) : If C = 4 Then Ext = "." & .Item(3)
End With: Set ShA = CreateObject("Shell.Application")
Set FSO  = CreateObject("Scripting.FileSystemObject")
Set List = FSO.OpenTextFile(List,,,-1)
Do : F = Trim(List.ReadLine)
  If F <> "" Then
    BN = FSO.GetFileName(F)
    If FSO.FolderExists(F) Then
      Test = 1 : Filt = 73888 : Ext = ""
    Else
      Test = 0 : Filt = 73920
      If Not Cnt2End Then BN = FSO.GetBaseName(BN) :_
      If C = 3 Then Ext = "." & FSO.GetExtensionName(F)
    End If : Ent = InStrRev(BN, "(") : Max = 0
    If Ent And Right(BN, 1) = ")" Then
      M = Mid(BN, Ent + 1, Len(BN) - Ent - 1)
      If IsNumeric(M) Then Max = CLng(M)
      BN = Left(BN, Ent - 2)
    End If
    Set Items = ShA.NameSpace(Path).Items
    Items.Filter Filt, BN & " (*)" & Ext
    Cnt = Items.Count : Ln = Len(BN) + 3
    If Cnt Then
      For x = 0 to Cnt - 1
        Item = Items.Item(x) : M = Mid(Item, Ln, Len(Item) - Ln - Len(Ext))
        If IsNumeric(M) Then : If CLng(M) > Max Then Max = CLng(M) End If
      Next
    End If
    For i = 1 To Count
      FN = FSO.BuildPath(Path, BN & " (" & Max + i & ")")
      If Test Then
        If C = 4 Then FSO.CreateFolder FN Else FSO.GetFolder(F).Copy FN, 0
      Else
        If C = 4 Then FSO.CreateTextFile(FN & Ext) Else FSO.CopyFile F, FN & Ext, 0
      End if
    Next
  End If
Loop Until List.AtEndOfStream
If Sec Then If Timer - T >= CDbl(Sec) Then _
CreateObject("WScript.Shell").Popup "Выполнено!", 1.4, " Создание копий", 4160

Примечание: Выбраны могут быть в т. ч. элементы <имя (№)>, будут создаваться <имя (№+1)>.
В случае, если получатель отличается от источника, и в нём нет копий со счётчиком, отчёт будет идти от № текущего элемента в выбранном списке.

Flasher
14.11.2014

A: Упрощённый вариант с заполнением промежутков в нумерации списка копий. Число копий указывается в окне.
'==============================================
' Cоздать копии для каждого выбранного элемента
' Параметры: %WL "<путь назначения>"
' Пример:    %WL "%P"
'==============================================
With WScript.Arguments
  If .Count = 0 Then WScript.Quit
  List = .Item(0) : Path = .Item(1)
End With : Set ShA = CreateObject("Shell.Application")
Set FSO = CreateObject("Scripting.FileSystemObject")
Count = InputBox(String(4, vbLf) & "Введите число создаваемых копий" & vbLf &_
"для каждого элемента списка :", Space(13) & "Создание копий выбранных элементов")
If IsNumeric(Count) Then
  With FSO.OpenTextFile(List,,,-1)
    Do Until .AtEndOfStream
      F = Trim(.ReadLine)
      For n = 1 To Abs(Count) : ShA.NameSpace(Path).CopyHere F, 8 : Next
    Loop : .Close
  End With
End If

Flasher
15.11.2014

Личные инструменты
Реклама