Batya
|
 Posted: Thu Oct 15, 2009 17:22 Post subject: |
 |
|
vbs-реакция 
| Code: | '=========================================================================
' Переименование файлов, представленных в файле-списке или в папке:
' если имя начинается на {Word1}, то {Word1} заменяется на {Word2};
' если имя начинается на {Word2}, то {Word2} удаляется из имени.
'
' Параметры:
' {файл-список}|{папка}
'
' Примеры параметров при вызове из TC:
' %L
' "%P"
'
' Автор - Batya
'=========================================================================
Option Explicit
'======== Изменяемые параметры ===========================================
Const Word1 = "печать_" 'Первое начало имен файлов
Const Word2 = "распечатано_" 'Второе начало имен файлов
'=========================================================================
Dim Mess, FSO, WSH, FF, IsFolder, F, LW1, LW2
On Error Resume Next
Main:CheckErr
On Error GoTo 0
MessBox Mess(3), 3
Quit 0
'Основная процедура
Sub Main
SetMess
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = CreateObject("WScript.Shell")
F = ""
CheckParam
LW1 = Len(Word1)
LW2 = Len(Word2)
If IsFolder Then
FolderProc FF
Else
For Each F In Split(FSO.OpenTextFile(FF).ReadAll, vbNewLine)
If F <> "" Then
F = GetPath(F)
If FSO.FileExists(F) Then
FileProc F
ElseIf FSO.FolderExists(F) Then
FolderProc F
End If
End If
Next
End If
End Sub
'Массив сообщений
Sub SetMess
Set Mess = CreateObject("Scripting.Dictionary")
With Mess
.Add 0, "Переименование по маске"
.Add 1, "Не указаны параметры!"
.Add 2, "Первый параметр не является файлом-списком или папкой!"
.Add 3, "Операция завершена."
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
If Not FSO.FolderExists(FF) Then
Err.Raise vbObjectError + 2, "", Mess(2)
Else
IsFolder = True
End If
Else
IsFolder = False
End If
End Sub
'Обработка файла
Sub FileProc(pPath)
Dim lFName, lNewPath
lFName = FSO.GetFileName(pPath)
If Left(LCase(lFName), LW1) = LCase(Word1) Then
lNewPath = FSO.GetParentFolderName(pPath) & "\" & Word2 & Mid(lFName, LW1 + 1)
FileMove pPath, lNewPath
ElseIf Left(LCase(lFName), LW2) = LCase(Word2) Then
lNewPath = FSO.GetParentFolderName(pPath) & "\" & Mid(lFName, LW2 + 1)
FileMove pPath, lNewPath
End If
End Sub
'Перемещение файла
Sub FileMove(pPath, pNewPath)
FSO.MoveFile pPath, pNewPath
End Sub
'Обработка папки
Sub FolderProc(pPath)
Dim loF
Set loF = FSO.GetFolder(pPath)
For Each F In loF.SubFolders
F = F.Path
FolderProc F
Next
For Each F In loF.Files
F = F.Path
FileProc F
Next
Set loF = Nothing
End Sub
'Разложить путь при наличии переменных окружения
Function GetPath(pPath)
GetPath = FSO.GetAbsolutePathName(WSH.ExpandEnvironmentStrings(pPath))
End Function
'Проверка, нет ли ошибок
Sub CheckErr
Dim lMess
lMess = "Возникла ошибка № " & Err.Number & ":" & vbNewLine & Err.Description
If F <> "" Then lMess = lMess & vbNewLine & vbNewLine & "Файл\папка:" & vbNewLine & F
If Err.Number <> 0 Then
MessBox lMess, 1
Quit Err.Number
End If
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
End Select
MessBox = MsgBox(pMess, lIcon, Mess(0))
End Function
'Выход
Sub Quit(pExitCode)
Set Mess = Nothing
Set WSH = Nothing
Set FSO = Nothing
WScript.Quit pExitCode
End Sub |
_________________
Нет, я не сплю. Я просто медленно моргаю.
Last edited by Batya on Fri Oct 16, 2009 14:11; edited 7 times in total |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
