Batya
|
 Posted: Wed Aug 19, 2009 17:03 Post subject: |
 |
|
RyzhkovVA
| Code: | '=============================================================================
' Переименование выделенных в TC файлов по маске "[DDMMYY] [C] [Add].[E]", где
' [DDMMYY] - текущая дата;
' [С] - счетчик - заглавная буква русского алфавита;
' [Add] - любая приставка (передается параметром):
' [E] - текущее расширение файла.
'
' Параметры:
' {файл-список\папка} {приставка}
'
' Примеры параметров при вызове из TC:
' %L 640
' "%P" "номер 3"
'
' Автор - Batya
'=============================================================================
Option Explicit
'======== Изменяемые параметры ===============================================
Const FolderRename = False 'Переименовывать ли папки (иначе - файлы в папках)
Const LenYear = 2 'Количество символов года в маске
Const MoreParams = True 'Считать все параметры после первого приставкой
Const StartCount = 192 'Номер первого символа счетчика по кодовой таблице
Const NewFoldCount = True 'Новый счетчик в каждой отдельной папке
'=============================================================================
Dim Mess, FSO, WSH, Errors, FF, Add, F, F1, Counter, CounterG
SetMess
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = CreateObject("WScript.Shell")
Set Errors = CreateObject("Scripting.Dictionary")
CheckParam
Counter = 0
If FSO.FolderExists(FF) Then
If Not FolderRename Then
For Each F In FSO.GetFolder(FF).Files
RenameFile F.Path, Counter
Counter = Counter + 1
Next
Else
RenameFolder FF, Counter
End If
Else
For Each F In Split(FSO.OpenTextFile(FF).ReadAll, vbNewLine)
If F <> "" Then
F = GetPath(F)
If Not FSO.FileExists(F) And Not FSO.FolderExists(F) Then
Errors.Add F, Mess(6)
Else
If FSO.FolderExists(F) Then
If Not FolderRename Then
If NewFoldCount Then
CounterG = Counter
Counter = 0
End If
For Each F1 In FSO.GetFolder(F).Files
RenameFile F1.Path, Counter
Counter = Counter + 1
Next
If NewFoldCount Then Counter = CounterG
Else
RenameFolder F, Counter
End If
Else
RenameFile F, Counter
Counter = Counter + 1
End If
End If
End If
Next
End If
If Errors.Count > 0 Then
MessBox Mess(5) & JoinErr(Errors), 2
Else
MessBox Mess(4), 3
End If
Quit 0
Sub SetMess
Set Mess = CreateObject("Scripting.Dictionary")
With Mess
.Add 0, "Переименование файлов по маске"
.Add 1, "Не указаны параметры!"
.Add 2, "Указанный первый параметр не является ни файлом-списком, ни папкой!"
.Add 3, "Файл\папка с подобным именем уже существует"
.Add 4, "Операция завершена."
.Add 5, "Операция завершена." & vbNewLine & vbNewLine & "Имеются ошибки:"
.Add 6, "Файл, либо папка не существуют!"
End With
End Sub
Sub CheckParam
Dim l, lCount
lCount = WScript.Arguments.Count
If lCount = 0 Then
MessBox Mess(1), 1
Quit 0
End If
FF = GetPath(WScript.Arguments(0))
If Not FSO.FileExists(FF) And Not FSO.FolderExists(FF)Then
MessBox Mess(2), 1
Quit 0
End If
If lCount = 1 Then
Add = ""
Else
If MoreParams Then
For l = 2 To lCount
Add = Add & " " & WScript.Arguments(l-1)
Next
Else
Add = " " & WScript.Arguments(1)
End If
End If
End Sub
Function GetPath(pPath)
GetPath = FSO.GetAbsolutePathName(WSH.ExpandEnvironmentStrings(pPath))
End Function
Sub RenameFile(pPath, pCounter)
Dim lNewPath, lCounter, lDate, lDateStr, lExt
lCounter = Chr(StartCount + pCounter)
lDate = Date
lDateStr = Right("0" & Day(lDate), 2) & Right("0" & Month(lDate), 2) & Right(Year(lDate), LenYear)
lExt = FSO.GetExtensionName(pPath)
lNewPath = FSO.GetParentFolderName(pPath) & "\" & lDateStr & " " & lCounter & Add & "." & lExt
If FSO.FolderExists(lNewPath) Or FSO.FileExists(lNewPath) Then
Errors.Add pPath, Mess(3) & " - " & lNewPath
Else
On Error Resume Next
FSO.MoveFile pPath, lNewPath
If Err.Number <> 0 Then
Errors.Add pPath, Err.Description
Err.Clear
End If
On Error GoTo 0
End If
End Sub
Sub RenameFolder(pPath, pCounter)
Dim lNewPath, lCounter, lDate, lDateStr
lCounter = Chr(StartCount + pCounter)
lDate = Date
lDateStr = Right("0" & Day(lDate), 2) & Right("0" & Month(lDate), 2) & Right(Year(lDate), LenYear)
lNewPath = FSO.GetParentFolderName(pPath) & "\" & lDateStr & " " & lCounter & Add
If FSO.FolderExists(lNewPath) Or FSO.FileExists(lNewPath) Then
Errors.Add pPath, Mess(3) & " - " & lNewPath
Else
On Error Resume Next
FSO.MoveFolder pPath, lNewPath
If Err.Number <> 0 Then
Errors.Add pPath, Err.Description
Err.Clear
End If
On Error GoTo 0
End If
End Sub
Function JoinErr(pDic)
Dim lKey
For Each lKey In pDic
JoinErr = JoinErr & vbNewLine & lKey & " - " & pDic(lKey)
Next
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 Quit(pQuitCode)
Set Mess = Nothing
Set WSH = Nothing
Set FSO = Nothing
Set Errors = Nothing
WScript.Quit pQuitCode
End Sub |
Практический совет - дату лучше писать в формате [YYMMDD], а не [DDMMYY]. Так нормально сортируется, и вообще визуально намного проще ориентироваться.
_________________
Нет, я не сплю. Я просто медленно моргаю. |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
