'••••••••••••••••••••••••••••••••• VBS •••••••••••••••••••••••••••••••••
' Копирование/перемещение по указанному пути выбранных в активной панели
' объектов (с сохранением относительных путей в режиме без подкаталогов)
' Параметры: %WL "%P" "<путь получателя>" <copy/move>
' Ключи:
' /с:[+/-]<число> — контроль глубины вложенности выбранных объектов
' a) Если перед числом +, добавляются папки справа пути источника.
' б) Если перед числом -, папки исключается слева относител. пути.
' в) Если знака нет, папки исключаются слева общего пути источника.
' /s:<секунд> — минимальное число секунд для оповещения об окончании
' /d — удалять опустевшие после перемещения файлов каталоги
' Примеры: %WL "%P" "%T" copy /c:2 /d
' %WL "%P" D:\NewFolder copy /s:20
' %WL "%P" "С:\New Folder" move /s:20 /с:-3
'••••••••••••••••••••••••••••••••••••••••••••••••• Автор: Flasher © ••••
Option Explicit : Dim T : T = Timer
Dim Lst, IPath, OPath, Act, C, S, D, Ln, Disk, Del, RExp, Max, Min
Dim RPath, Del2, TF, F, PF, Fd, FN, BN, Ext, i, TFile, FType, Sec
With WSH.Arguments
If .Count = 0 Then WSH.Quit: End If : Lst = .Item(0)
IPath = .Item(1) : OPath = .Item(2) : Act = .Item(3)
D = Eval(LCase(Act) = "move" And .Named.Exists("d"))
C = .Named("c") : S = .Named("s")
End With
With CreateObject("Scripting.FileSystemObject")
If Not (.FolderExists(IPath) Or .FolderExists(OPath)) Or (C = "" And _
StrComp(.BuildPath(IPath,"\"), .BuildPath(OPath,"\"), 1) = 0) Then WSH.Quit
Set Disk = CreateObject("Shell.Application").NameSpace(Left(OPath, 2))
If C = "0" Then OPath = .BuildPath(OPath, Replace(IPath, ":", ""))
If StrComp(Left(IPath, 1), Left(OPath, 1), 1) <> 0 Then _
If LCase(Act) = "move" Then Act = "Copy" : Del = " : .Delete"
Set RExp = New RegExp : Ln = Len(IPath)
If Right(IPath, 1) = "\" Then Max = 1 Else Ln = Ln + 1
If C > 0 And IsNumeric(C) Then
Max = UBound(Split(IPath, "\")) - Max + 1
If CInt(C) > Max Then
If Left(C, 1) = "+" Then C = Max Else C = 0
ElseIf Left(C, 1) <> "+" Then C = Max - C End If
RExp.Pattern = "((\\[^\\]+){" & CInt(C) & "})\\?$"
OPath = .BuildPath(OPath, Replace(RExp.Execute(_
"\" & IPath)(0).SubMatches(0), ":", ""))
End If : Set TF = .OpenTextFile(Lst,,,-1)
Do : F = TF.ReadLine : PF = .GetParentFolderName(F)
If Right(F, 1) = "\" Then F = Left(F, Len(F) - 1)
RPath = Mid(PF, Ln) : Del2 = ""
If C < 0 Then
Max = UBound(Split(RPath, "\")) + 1 : Min = Abs(C)
If Min > Max Then Min = 0 Else Min = Max - Min
RExp.Pattern = "(\\[^\\]+){" & Min & "}$"
RPath = RExp.Execute(RPath)(0)
End If
If IPath = "" Then Fd = OPath Else _
Fd = .BuildPath(OPath, RPath) : Disk.NewFolder Mid(Fd, 4)
FN = .GetFileName(F) : BN = .GetBaseName(F) : i = 0
Ext = .GetExtensionName(F) : If Len(Ext) Then Ext = "." & Ext
While .FileExists(Fd & "\" & FN) Or .FolderExists(Fd & "\" & FN)
i = i + 1 : FN = BN & " (" & i & ")" & Ext
Wend : If .FileExists(F) Then FType = "File" Else FType = "Folder"
If Len(Del) Then Del2 = FType & " F, 1"
Execute "." & Act & FType & " F, Fd & ""\"" & FN" & Del & Del2
If D And Right(PF, 1) <> "\" Then
Do : If .GetFolder(PF).Size = 0 Then .DeleteFolder PF, 1
PF = .GetParentFolderName(PF)
Loop Until IPath = .BuildPath(PF, "\")
End If
Loop Until TF.AtEndOfStream : TF.Close
End With : CreateObject("WScript.Shell").SendKeys "^r"
Sec = Timer - T
If S > 0 And CSng(S) <= Sec Then
If Sec < 60 Then Sec = 1.4 Else Sec = ""
If LCase(Act) = "copy" Then Act = " " &_
"Копирование " Else Act = " Перемещение "
CreateObject("WScript.Shell").Popup Space(7) &_
"Выполнено!", Sec, Act & "выбранного ", 4160
End If |