Batya
|
 Posted: Mon Nov 23, 2009 13:21 Post subject: |
 |
|
| Rustem wrote: | | Здравствуйте все ! Нужен скрипт для следующей задачи : |
| Code: | '====================================================================================
' Для указанных файлов\папок в зависимости от текущего пути
' производится копирование или перемещение в заданные папки.
'
' Параметры:
' {файл-список}
'
' Пример параметров при вызове из TC:
' %L
'
' Автор - Batya
'====================================================================================
Option Explicit
Dim FLD
Set FLD = CreateObject("Scripting.Dictionary")
'======== Изменяемые параметры ======================================================
' Массив обрабатываемых папок по шаблону:
' FLD.Add "{Исходная папка}", Array({Режим}, "Папка 1", ..., "Папка N")
FLD.Add "D:\Источник_1\", Array(0, "H:\На печать", "I:\На архивацию")
FLD.Add "Е:\Источник_2\", Array(1, "K:\Заархивировано", "L:\Передано")
FLD.Add "G:\Источник_N\", Array(1, "M:\Путь 5", "N:\Путь 6")
' где {Режим}:
' 0 - копирование исходной папки в "Папка 1", ..., "Папка N";
' 1 - копирование исходной папки в "Папка 1", ..., "Папка N" с последующим удалением.
'====================================================================================
Dim Mess, FSO, WSH, FF
SetMess
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = CreateObject("WScript.Shell")
'On Error Resume Next
CheckParam:CheckErr
Main:CheckErr
On Error GoTo 0
MessBox Mess(5), 3
Quit 0
Sub Main
Dim F, lF, Arr, i, IsFolder, lTF
For Each F In Split(FSO.OpenTextFile(FF).ReadAll, vbNewLine)
If F <> "" Then
lF = GetPath(F)
If Not (FSO.FileExists(lF) Or FSO.FolderExists(lF)) Then Err.Raise vbObjectError + 3, "", _
Mess(3) & vbNewLine & F
IsFolder = False
If FSO.FolderExists(lF) Then IsFolder = True
Arr = FLD(RootFolder(F, FLD))
If IsFolder Then
For i = 1 To UBound(Arr)
lTF = GetPath(Arr(i))
If Not FSO.FolderExists(lTF) Then Err.Raise vbObjectError + 4, "", _
Mess(4) & vbNewLine & Arr(i)
FSO.CopyFolder lF, lTF & "\"
Next
If Arr(0) = 1 Then FSO.DeleteFolder lF
Else
For i = 1 To UBound(Arr)
lTF = GetPath(Arr(i))
If Not FSO.FolderExists(lTF) Then Err.Raise vbObjectError + 4, "", _
Mess(4) & vbNewLine & Arr(i)
FSO.CopyFile lF, lTF & "\"
Next
If Arr(0) = 1 Then FSO.DeleteFile lF
End If
End If
Next
End Sub
Sub SetMess
Set Mess = CreateObject("Scripting.Dictionary")
With Mess
.Add 0, "Копирование\перемещение в зависимости от текущего пути"
.Add 1, "Не указаны параметры!"
.Add 2, "Файл-список не существует!"
.Add 3, "Указанный файл или папка не существует:"
.Add 4, "Целевая папка не существует:"
.Add 5, "Операция завершена."
End With
End Sub
Sub CheckParam
If WScript.Arguments.Count = 0 Then Err.Raise vbObjectError + 1, "", Mess(1)
FF = GetPath(WScript.Arguments(0))
If Not FSO.FileExists(FF) Then Err.Raise vbObjectError + 2, "", Mess(2)
End Sub
Function RootFolder(pPath, pDict)
Dim lK, l, lF
RootFolder = ""
For Each lK In pDict.Keys
lF = GetPath(lK)
l = Len(lF)
If UCase(lF) = UCase(Left(pPath, l)) Then
RootFolder = lK
Exit For
End If
Next
End Function
Function GetPath(pPath)
GetPath = FSO.GetAbsolutePathName(WSH.ExpandEnvironmentStrings(pPath))
End Function
Function MessBox(pMess, pMode)
Dim lIcon
Select Case pMode
Case 1 lIcon = vbCritical + vbOKOnly
Case 2 lIcon = vbExclamation + vbOKOnly
Case 3 lIcon = vbInformation + vbOKOnly
End Select
MessBox = MsgBox(pMess, lIcon, Mess(0))
End Function
Sub CheckErr
If Err.Number <> 0 Then
MessBox "Возникла ошибка № " & Err.Number & ":" & vbNewLine & Err.Description, 1
Quit Err.Number
End If
End Sub
Sub Quit(pQuitCode)
Set FLD = Nothing
Set Mess = Nothing
Set WSH = Nothing
Set FSO = Nothing
WScript.Quit pQuitCode
End Sub
|
_________________
Нет, я не сплю. Я просто медленно моргаю. |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
