'•••••••••••••••••••••••• 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, REx, Rgx, T, Ren,_
D, Dic, Col, ShA, oFolder, oList, List, Folders,_
N, Items, F, Nm, Targ, Lnk, i, FPath, FlEx, FdEx
Set A = WSH.Arguments : If A.Count = 0 Then WSH.Quit
Set FSO = CreateObject("Scripting.FileSystemObject")
Set REx = New RegExp : REx.Pattern = "([.+[\(){$^])"
Set Rgx = New RegExp : Rgx.IgnoreCase = True
T = Timer: If A.Named.Exists("r") Then Ren = 8
REx.Global = True : D = FSO.GetDriveName(A(1))
Set Dic = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
Set ShA = CreateObject("Shell.Application")
ShA.NameSpace(D).NewFolder Mid(A(1), Len(D) + 2)
Set oFolder = ShA.NameSpace(FSO.GetAbsolutePathName(""))
List = FSO.OpenTextFile(A(0),,,-1).ReadAll
oList = Split(List, vbNewLine)
For Each N in Filter(oList, ";")
Nm = N
If StrComp(FSO.GetExtensionName(N), "lnk", 1) _
= 0 Then N = oFolder.ParseName(N).GetLink.Target
Set Items = oFolder.Items
Items.Filter 78064, Replace(N, ";", "?")
Rgx.Pattern = "(^|\n)" & REx.Replace(N, "\$1") & "(\r|$)"
For Each F in Items
If Not F.IsLink Then N = "" Else N = F.GetLink.Path
F = FSO.GetFileName(F.Path)
If InStr(F, ";") Then Dic.Add F, N : Exit For
Next : List = Rgx.Replace(List, "$1")
Next
Rgx.Pattern = "\r\n$" : List = Rgx.Replace(List, "")
Folders = Left(List, InStrRev(List, "\"))
For Each N in Filter(oList, ".lnk", 1, 1)
If InStr(N, ";") = 0 Then
With oFolder.ParseName(N)
If .IsLink Then _
Col.Add N, .GetLink.Path : Rgx.Pattern = "(^|\n)" &_
REx.Replace(FSO.GetBaseName(N),"\$1") & "\.lnk(\r|$)":_
List = Rgx.Replace(List, "$1" & .GetLink.Target & "$2")
End With
End If
Next : Set Items = oFolder.Items
Rgx.Pattern = "(^|\n)" & FSO.GetFileName(A(1)) & "\\(\r|$)"
List = Rgx.Replace(List, "$1") : If List = "" Then WSH.Quit
Set Targ = ShA.NameSpace(A(1)) : Items.Filter 78064,_
Replace(Replace(List, "\", ""), vbCrLf, ";")
Execute "Targ." & A(2) & "Here Items, 4112 + Ren"
For Each D in Array(Dic, Col)
If D.Count Then
For Each F in D
FPath = D(F) : FlEx = FSO.FileExists(FPath)
FdEx = FSO.FolderExists(FPath)
If FlEx Or FdEx Then
If LCase(A(2)) = "move" Then _
If FlEx Then FSO.DeleteFile F, 1 Else FSO.DeleteFolder F, 1
Targ.CopyHere FPath, 4112 + Ren
End If
Next
End If : Set D = Nothing : i = 1
Next
For Each F in Split(Folders, vbCrLf) : FFolder FSO.BuildPath(A(1), F) : Next
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
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 File.IsLink And LCase(FSO.GetExtensionName(File.Path)) <> "url" Then _
oFold.CopyHere File.GetLink.Path, 4112 + Ren : FSO.DeleteFile File.Path, 1
Next : Items.Filter 78000, "*"
For Each Fold in FSO.GetFolder(Folder).SubFolders
If FSO.FolderExists(Fold) Then FFolder Fold.Path
Next
End Sub |