Код: Выделить всё
'•••••••••••••••••••••••• 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
Бред какой-то. Это вообще никак не может быть связано с тем, ярлык это или что-то иное. Откуда там взяться ошибке, неясно. Проверь выполнение условия и параметры.
