'==============================================================================
' Copy2SamePath.vbs
' Копирование выделенных файлов в папку, отличающуюся буквой диска
' Параметры вызова для кнопки: %WL {новый диск}
' (второй параметр можно опустить). Пример параметров:
' %WL F
'
' by Rodny
' v. 0.4
' http://forum.ru-board.com/topic.cgi?forum=5&topic=45288&start=1960#12
'==============================================================================
Option Explicit
Dim WSH, FSO, ListFile, FileName, FilePath, Disk, NewFile, NewPath, Files, File, c
Set WSH = CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
ListFile = WScript.Arguments(0)
Disk = ""
Do
If WScript.Arguments.Count = 1 Then
Disk = InputBox("Задайте диск назначения" & VBNewLine & "(без кавычек)", "Требуется указать диск")
Else Disk = WScript.Arguments(1)
End If
If IsEmpty(Disk) Then
WScript.Quit
End If
Loop While Disk = ""
c = 0
Files = Split(FSO.GetFile(ListFile).OpenAsTextStream(1,-1).ReadAll, vbNewLine)
For Each File in Files
If (Trim(File) > vbNullString) And (Right(File, 1) <> "\") Then
Set FileName = FSO.GetFile(File)
Set FilePath = FSO.GetFile(File).ParentFolder
' Новый путь
NewFile = Disk & Right(File, Len(File) - 1) '& "\" & FileName
NewPath = Disk & Right(FilePath, Len(FilePath) - 1)
If Not FSO.FolderExists(NewPath) Then
FoldersCreate(NewPath)
End If
FileName.Copy NewFile
c = c + 1
End If
Next
' Если сообщение в конце не требуется - закомментировать следующую строчку (поставить первым символом ')
MsgBox "Скопировано файлов: " & c, vbOKOnly, "Готово" ' ОТЛАДКА
Function FoldersCreate(Folder)
Dim PF
Do
PF = FSO.GetParentFolderName(Folder)
If FSO.FolderExists(PF) Then
If Not FSO.FolderExists(Folder) Then
FSO.CreateFolder(Folder)
End If
Else
FoldersCreate PF & "\"
End If
Loop While Not FSO.FolderExists(Folder)
End Function
Set WSH = Nothing
Set FSO = Nothing
Set FileName = Nothing
Set FilePath = Nothing
Wscript.Quit() |
