'•••••••••••••••••••••••• VBS ••••••••••••••••••••••••
' Копирование/перемещение выбранного по заданному пути
' с последующей заменой lnk-ярлыков на целевые объекты

' Условие:    путь запуска — пустой
' Примечание: в пути достаточно правильной буквы диска
'
' Параметры: %WF "<путь назначения>" <copy/move>
' Ключ системного автопереименования объектов: /r

' Примеры:   %WF "%PMy Folder" copy /r
'            %WF D:\New\New2\New3\New4\New5 move
'•••••••••••••••••••••••••••••••• Автор: Flasher © •••

Option Explicit : Dim A, FSO, CD, T, Ren, Dic, Del, Col,_
ShA, Fds, TPath, Dash, D, All, Sp, oList, oFolder, Targ,_
NP, Items, N, BN, Ex, c, Equal, Exist, Nr, List, F, Ext

Set A = WSH.Arguments : If A.Count = 0 Then WSH.Quit
Set FSO = CreateObject("Scripting.FileSystemObject")
CD = FSO.BuildPath(FSO.GetAbsolutePathName(""), "\")
T = Timer: If A.Named.Exists("r") Then Ren = 8
Set Dic = CreateObject("Scripting.Dictionary")
Set Fds = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
Set Del = CreateObject("Scripting.Dictionary")
Set ShA = CreateObject("Shell.Application")
TPath = FSO.BuildPath(A(1), "\")
If LCase(A(2)) = "move" And StrComp(CD, TPath, 1) = 0 Then WSH.Quit
With CreateObject("CDO.Message")._
AddAttachment("res://shell32.dll/6/262").GetDecodedContentStream
   .Type = 1 :   For c = 0 To 2 : D = .Read(AscB(.Read(2)) * 2) : Next
  If InStr(D, "-") Then Dash = "-" Else Dash = "—"
End With
D = FSO.GetDriveName(TPath)
ShA.NameSpace(D).NewFolder Mid(TPath, Len(D) + 2)
With CreateObject("SAPI.SpFileStream")
   .Format.Type = 1 : .Open A(0), 0
  .Read All, FSO.GetFile(A(0)).Size : .Close
End With : All = Mid(CStr(All), 2)
Set oList = FSO.OpenTextFile(A(0),,,-1)
Set oFolder = ShA.NameSpace(CD)
Set Targ = ShA.NameSpace(TPath)
Set Items = oFolder.Items

Do : N = oList.ReadLine : D = N
  NP = CD & N : Equal = True : Exist = True
  If Right(N, 1) = "\" Then
    If Ren Then
      Nr = N : BN = Replace(N, "\", "") : c = 1
      While FSO.FolderExists(TPath & Nr)
        If c > 1 Then Ex = " (" & c & ")"
        Nr = BN & " " & Dash & " копия" & Ex : c = c + 1
      Wend : Fds.Add Nr, ""
    Else Fds.Add N, "" End If
  End If
  With oFolder.ParseName(N)
    If .IsLink Then NP = .GetLink.Path: N = FSO.GetFileName(NP):_
    Exist = FSO.FileExists(NP) Or FSO.FolderExists(NP) :_
    Equal = StrComp(FSO.GetParentFolderName(NP) & "\", CD, 1) = 0
  End With
  If Exist And Not Dic.Exists(N) Then
    Nr = Replace(N, ";", "?")
    If Not (Ren = "" And Equal) Then
      Items.Filter 78064, Nr
      If Items.Count = 1 Then
        Sp = "" : If Equal Then Sp = " "
        If Not IsLnk(oFolder.ParseName(D), N) Then _
        List = List & ";" & Nr Else Dic.Add D, Sp & NP
      Else
        For Each F in Items
          If IsLnk(F, N) Then _
          If InStr(vbCr & All, vbCr & FSO.GetFileName(F.Path) &_
          vbCr) Then FSO.GetFile(F.Path).Delete(1)
        Next : Items.Filter 78064, Nr : c = 0
        If Items.Count > 1 Then
          For Each F in Items
            If IsLnk(F, N) Then
              If LCase(A(2)) = "move" Then Del.Add F.Path, ""
            Else Col.Add F.Path, "" End If : c = c + 1
            If c = Items.Count Then Exit For
          Next
        Else If Equal Then List = List & ";" & Nr Else Dic.Add D, NP
        End If
      End If
    Else If Equal Then Dic.Add D, " " & NP Else List = List &";"& Nr
    End If
  End If
Loop Until oList.AtEndOfStream : oList.Close

If IsEmpty(List) Then
  If Dic.Count = 0 And Col.Count = 0 Then WSH.Quit
Else
  Items.Filter 78064, MId(Replace(List, "\", ""), 2)
  Execute "Targ." & A(2) & "Here Items, 12304 + Ren"
End If

For Each F in Del
  If FSO.FileExists(F) Then FSO.DeleteFile F, 1 Else FSO.DeleteFolder F, 1
Next
For Each N in Dic
  Nr = Dic(N) : F = LTrim(Nr) : D = 1
  If FSO.FileExists(F) Or FSO.FolderExists(F) Then
    If Left(Nr, 1) = " " Then If LCase(FSO._
    GetExtensionName(N)) = "lnk" Then FSO.DeleteFile N, 1 : D = 0
    Targ.CopyHere F, 12304 + Ren
    If LCase(A(2)) = "move" And D Then If FSO.FileExists(N) Then _
    FSO.DeleteFile N, 1 Else FSO.DeleteFolder N, 1
  End If
Next : Set Dic = Nothing : c = 1

For Each F in Col.Keys
  Ext = FSO.GetExtensionName(F) : If Len(Ext) Then Ext = "." & Ext
  BN = FSO.GetBaseName(F) : Ex = Ext : N = BN & Ex
  While FSO.FileExists(TPath & N) Or FSO.FolderExists(TPath & N)
    If c > 1 Then Ex = " (" & c & ")" & Ext
    N = BN & " " & Dash & " копия" & Ex : c = c + 1
  Wend : N = TPath & N : If Not (Ren = "" And c > 1) Then _
  If FSO.FileExists(F) Then FSO.CopyFile F, N Else FSO.CopyFolder F, N
  If LCase(A(2)) = "move" Then If FSO.FileExists(F) Then _
  FSO.DeleteFile F, 1 Else FSO.DeleteFolder F, 1
Next : Set Col = Nothing

For Each N in Fds : FFolder TPath & N : Next : Set Fds = Nothing
T = Timer - T
If T > 3 Then
  Dim Sec, Title : If T < 10 Then Sec = 2 Else If T < 30 Then Sec = 4
  Title = "Копирование": If LCase(A(2)) = "move" Then Title = "Перемещение"
  CreateObject("WScript.Shell").Popup "Выполнено!", Sec, " " & Title, 4160
End If

Function IsLnk(Item, N)
  If Right(N, 1) = "\" Then IsLnk = False Else _
  IsLnk = Item.IsLink And LCase(Right(Item.Path, 4)) = ".lnk"
End Function

Sub FFolder(Folder)
  Dim oFold, File, Fold
  Set oFold = ShA.NameSpace(Folder)
  Set Items = oFold.Items : Items.Filter 78032, "*"
  For Each File in Items
    If IsLnk(File, "") Then oFold.CopyHere File._
    GetLink.Path, 12304 + Ren : FSO.DeleteFile File.Path, 1
  Next : Items.Filter 77984, "*"
  For Each Fold in FSO.GetFolder(Folder).SubFolders
    If FSO.FolderExists(Fold) Then FFolder Fold.Path
  Next
End Sub