'==============================================================================
' Копирование выделенных файлов\папок в противоположную панель ТС
' Параметры вызова из TC:
' %L "%T" [{режим копирования}]
' где необязательный параметр {режим копирования} может принимать значения:
' 0 - если в файле-списке указана папка, а не файл, то вложенные файлы и папки
' копируются с сохранением относительной структуры (по умолчанию);
' 1 - копирование всех файлов в корень целевой папки;
' 2 - копирование с созданием полной стуктуры вложенных папок относительно
' корня диска
' Если 1-ый параметр указан пустым (""), то файл-список выбирается вручную
' Если 2-ой параметр указан пустым (""), то целевая папка выбирается вручную
'==============================================================================
Option Explicit
'===== Изменяемые параметры ===================================================
Const Overwrite = False 'Признак перезаписи существующих файлов
Const IgnorePrefix = "file://localhost/" 'Игнорируемый префикс
'==============================================================================
Dim FSO, FileList, TargetDir, Mess, Mess1, List, F, Errors, MessMode
Dim FilesAmount, FoldersAmount, CopyMode, Depth, i, oSA, CopyFlags, WSH
SetMess
Set oSA = CreateObject("Shell.Application")
Set WSH = CreateObject("WScript.Shell")
CheckParam
List = Split(FSO.OpenTextFile(FileList, 1).ReadAll, vbNewLine)
If Overwrite Then
CopyFlags = 16
Else
CopyFlags = 0
End If
Set Errors = CreateObject("Scripting.Dictionary")
If CopyMode = 2 Then
Set Depth = CreateObject("Scripting.Dictionary")
End If
FilesAmount = 0
FoldersAmount = 0
For Each F In List
F = Trim(F)
If F <> "" Then
If LCase(Left(F, Len(IgnorePrefix))) = LCase(IgnorePrefix) Then
F = Mid(F, Len(IgnorePrefix) + 1)
End If
F = GetPath(F)
On Error Resume Next
Copy F, TargetDir
On Error GoTo 0
End If
Next
If FilesAmount > 0 Then
Mess1 = Mess(6) & " " & FilesAmount & " " & Mess(7)
End If
If FoldersAmount > 0 Then
Mess1 = Mess1 & vbNewLine & Mess(6) & " " & FoldersAmount & " " & Mess(13)
End If
If (FilesAmount = 0) And (FoldersAmount = 0) Then
Mess1 = Mess(8)
End If
If Errors.Count > 0 Then
MessMode = 2
Else
MessMode = 3
End If
Mess1 = Mess1 & vbNewLine & JoinErr(Errors)
MessBox Mess1, MessMode
Quit
Sub CheckParam
If WScript.Arguments.Count = 0 Then
MessBox Mess(1), 1
Quit
End If
If WScript.Arguments.Count < 2 Then
MessBox Mess(2), 1
Quit
End If
FileList = WScript.Arguments(0)
TargetDir = WScript.Arguments(1)
Set FSO = CreateObject("Scripting.FileSystemObject")
If FileList = "" Then
FileList = OpenFile
Else
FileList = GetPath(FileList)
End If
If TargetDir = "" Then
TargetDir = OpenFolder
Else
TargetDir = GetPath(TargetDir)
End If
If Not FSO.FileExists(FileList) Then
MessBox Mess(3), 1
Quit
End If
If Not FSO.FolderExists(TargetDir) Then
MessBox Mess(4), 1
Quit
End If
If FSO.GetFile(FileList).Size = 0 Then
MessBox Mess(5), 1
Quit
End If
If WScript.Arguments.Count > 2 Then
CopyMode = WScript.Arguments(2)
If Not (CopyMode = 0 Or CopyMode = 1 Or CopyMode = 2) Then
MessBox Mess(11), 1
Quit
End If
Else
CopyMode = 0
End If
End Sub
Sub SetMess
Set Mess = CreateObject("Scripting.Dictionary")
Mess.Add 0, "Копирование из файла-списка"
Mess.Add 1, "Не указаны входные параметры!"
Mess.Add 2, "Указаны не все входные параметры!"
Mess.Add 3, "Файл-список не существует!"
Mess.Add 4, "Целевая папка не существует!"
Mess.Add 5, "Файл-список пустой!"
Mess.Add 6, "Успешно скопировано"
Mess.Add 7, "файлов."
Mess.Add 8, "Ничего не удалось скопировать."
Mess.Add 9, "Не удалось выполнить копирование"
Mess.Add 10, "по причине ошибки:"
Mess.Add 11, "Неправильно указан режим копирования!"
Mess.Add 12, "Успешно создано"
Mess.Add 13, "папок."
Mess.Add 14, "В целевой папке данный файл уже существует!"
Mess.Add 15, "Выбирете целевую папку"
Mess.Add 16, "Файл-список"
Mess.Add 17, "Ошибка не известна."
Mess.Add 18, "Введите путь к файлу-списку."
Mess.Add 19, "Введено несуществующее имя файла." & vbNewLine & "Нажмите ""OK"" для повторного ввода."
End Sub
Function MessBox(pMess, pMode)
Dim lIcon
Select Case pMode
Case 1 lIcon = vbCritical + vbOKOnly
Case 2 lIcon = vbExclamation + vbOKOnly
Case 3 lIcon = vbInformation + vbOKOnly
Case 4 lIcon = vbExclamation + vbOKCancel
End Select
MessBox = MsgBox(pMess, lIcon, Mess(0))
End Function
Function JoinErr(pDic)
Dim lKey
For Each lKey In pDic
JoinErr = JoinErr & vbNewLine & vbNewLine & _
Mess(9) & " """ & lKey & """ " & Mess(10) & _
vbNewLine & pDic(lKey)
Next
End Function
Sub Copy(pF, pTarget)
Dim lF, oF, lTarget, oNS
lTarget = pTarget
If Right(lTarget, 1) <> "\" Then
lTarget = lTarget & "\"
End If
If CopyMode = 2 Then
lTarget = CopyFolderStructure(lTarget, pF)
End If
If FSO.FileExists(pF) Then
If (Not Overwrite) And FSO.FileExists(lTarget & FSO.GetFile(pF).Name) Then
Errors.Add pF, Mess(14)
Else
CreateFoldersTree lTarget
Set oNS = oSA.NameSpace(lTarget)
oNS.CopyHere pF, CopyFlags
Set oNS = Nothing
If Err.Number <> 0 Then
Errors.Add pF, Err.Description
Else
If Not FSO.FileExists(lTarget & FSO.GetFile(pF).Name) Then
Errors.Add pF, Mess(17)
Else
FilesAmount = FilesAmount + 1
End If
End If
End If
End If
If FSO.FolderExists(pF) Then
CreateFoldersTree lTarget
Set oF = FSO.GetFolder(pF)
If (CopyMode = 0) Or (CopyMode = 2) Then
Set oNS = oSA.NameSpace(lTarget)
oNS.CopyHere pF, CopyFlags
Set oNS = Nothing
If Err.Number <> 0 Then
Errors.Add pF, Err.Description
Else
If Not FSO.FolderExists(lTarget & oF.Name) Then
Errors.Add pF, Mess(17)
Else
FoldersAmount = FoldersAmount + 1
End If
End If
End If
If CopyMode = 1 Then
For Each lF In oF.Files
If (Not Overwrite) And FSO.FileExists(lTarget & lF.Name) Then
Errors.Add lF.Path, Mess(14)
Else
Set oNS = oSA.NameSpace(lTarget)
oNS.CopyHere lF.Path, CopyFlags
Set oNS = Nothing
If Err.Number <> 0 Then
Errors.Add lF.Path, Err.Description
Else
If Not FSO.FileExists(lTarget & lF.Name) Then
Errors.Add lF.Path, Mess(17)
Else
FilesAmount = FilesAmount + 1
End If
End If
End If
Next
For Each lF In oF.SubFolders
Copy lF.Path, lTarget
Next
Set lF = Nothing
End If
Set oF = Nothing
End If
End Sub
Function CopyFolderStructure(pTarget, pPath)
Dim lPath
If FSO.FileExists(pPath) Then
lPath = FSO.GetParentFolderName(pPath) & "\"
Else
lPath = FSO.GetAbsolutePathName(pPath) & "\"
End If
Depth.RemoveAll
GetDepth lPath
CopyFolderStructure = pTarget
For i = Depth.Count To 1 Step -1
CopyFolderStructure = CopyFolderStructure & Depth(i) & "\"
Next
End Function
Sub CreateFoldersTree(pFolder)
Dim lParentFolder
If Not FSO.FolderExists(pFolder) Then
lParentFolder = FSO.GetParentFolderName(pFolder)
If Not FSO.FolderExists(lParentFolder) Then
CreateFoldersTree(lParentFolder)
End If
FSO.CreateFolder(pFolder)
End If
End Sub
Sub GetDepth(pPath)
Depth.Add Depth.Count + 1, FSO.GetFolder(pPath).Name
If FSO.GetDriveName(pPath) & "\" <> FSO.GetParentFolderName(pPath) Then
GetDepth FSO.GetParentFolderName(pPath)
End If
End Sub
Function OpenFile
Dim Dlg, DlgResult
On Error Resume Next
Set Dlg = CreateObject("UserAccounts.CommonDialog")
If Err.Number = 0 Then
On Error GoTo 0
Dlg.Filter = Mess(16) & " (*.*)|*.*"
Dlg.Flags = &H4 + &H8 + &H400 + &H1000 + &H80000
DlgResult = Dlg.ShowOpen
If DlgResult Then
OpenFile = Dlg.FileName
End If
Set Dlg = Nothing
If Not DlgResult Then
Quit
End If
Else
On Error GoTo 0
Do
Dlg = InputBox(Mess(18), Mess(0))
If Dlg = "" Then
Quit
Else
Dlg = GetPath(Dlg)
End If
If Not FSO.FileExists(Dlg) Then
Dlg = ""
DlgResult = MessBox(Mess(19), 4)
If DlgResult = vbCancel Then
Quit
End If
End If
Loop Until (Dlg <> "")
OpenFile = Dlg
End If
End Function
Function OpenFolder
Dim oF, lSelect
Set oF = oSA.BrowseForFolder(0, Mess(15), 16)
lSelect = Not (TypeName(oF) = "Nothing")
If lSelect Then
OpenFolder = oF.Self.Path
End If
Set oF = Nothing
If Not lSelect Then
Quit
End If
End Function
Function GetPath(pPath)
GetPath = FSO.GetAbsolutePathName(WSH.ExpandEnvironmentStrings(pPath))
End Function
Sub Quit
Set Errors = Nothing
Set Depth = Nothing
Set Mess = Nothing
Set FSO = Nothing
Set oSA = Nothing
Set WSH = Nothing
WScript.Quit
End Sub |
(( Для этих целей в vbs можно использовать соответствующий макрос из TCScript.Helper.
