Total Commander

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

'••••••••••••••••••••••••••••••••• 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