Тема: VBScript: Перенумерация файлов и папок
Перенумерация файлов и папок.
Лирическое отступление 
Не знаю кому как, а мне слишком часто приходится изменять числовую нумерацию в именах файлов. То в документации. То в архиве фоток. То отсканированные листы надо перименовать и перенумеровать. Недавно архив комиксов разбирал, то же этот скрипт пригодился.
Скрипт предназначен для выполнения двух задач:
- изменение существующей нумерации файлов или папок с заданным шагом.
- выравнивание существующей нумерации до нужной длины для обеспечения нормальной сортировки файлов.
Для запуска использовать cscript.
- Скрипт ищет в именах файлов или папок числовые значения и изменяем их с заданным шагом (в случае перенумерации) или выравнивает их до нужного количества цифр (в случае выравнивания). При выравнивании число либо дополняется слева нулями до нужной длины, либо усекается до нужной длины, отбрасыванием лишних цифр. В случае отключения выравнивания (/NA) отбрасыватся ведущие нули.
- Расширения файлов (но не папок) игнорируются.
- Можно задать маску файлов/папок, подлежащих обработке. Маска задаётся стандартным для dos/windows способом с использованием подстановочных знаков "*" и "?". Можно перечислить несколько масок, разделив их с точкой с запятой.
- Начальное значение счётчика задаётся числом. Если в числе цифр больше одной и есть ведущие нули, длина числа берётся в качестве поля для выравнивания. Например, если требуется нумерация с единицы и цифр должно быть 5, необходимо ввести 00001, или использовать параметр /A5.
- Если начальный счётчик не задан, выполняется только выравнивание чисел дополнением нулями или усечение слева до количества, заданного параметром /A, либо выполняется отбрасывание незначащих нулей слева, если использован параметр /NA.
- Если в имени чисел несколько, обрабатывается последнее. При необходимости можно выбрать, какое число обрабатывать (параметр /M#).
- Задав специальный параметр /FF можно взять начальный номер из первого обработанного файла. Чтобы не вводить его вручную...
- В конце делается пауза, чтобы посмотреть результат.
- Сортировка обрабатываемых файлов лежит на совести ОС (по алфавиту, типу и т.п.)
- Файлы и папки обрабатываются только в текущей папке, без обхода подпапок.
- Код возврата - количество переименованных файлов (0 - переименований не было) или -1 в случае ошибки в параметрах.
- Косую черту "/" перед параметрами можно не ставить.
- Есть режим тестирования (/T) для проверки без реального переименования файлов и папок.
- Скрипт обрабатывает файл descript.ion с описаниями файлов (используется в FAR Manager) в кодировке CP-1251 и при необходимости вносит в него исправления.
vrenum.vbs
' Перенумерация файлов или папок
' 2011.07.31 - v.1.05
' 2011.08.12 - v.1.06
Option Explicit
On Error Resume Next
Dim x
Dim fso, shl, rex, shap
Dim m, mat, mats, matn, matv, matp, matl
Dim a, au, args
Dim a1, a_int, a_val
Dim newv, newl
Set fso = CreateObject("Scripting.FileSystemObject")
Set shl = CreateObject("WScript.Shell")
Set rex = New RegExp
Set shap = CreateObject("Shell.Application")
' Аргументы
Dim p_quiet, p_pause, p_test
Dim p_descr, p_align, p_renum
Dim p_field, p_slen, p_start, p_step, p_firstf
Dim p_mask, p_files, p_folders
Dim p_matlast, p_matnum
p_quiet = 0
p_pause = True
p_test = False
p_descr = True
p_field = 0 ' Поле для выравнивания
p_align = True ' Выравнивание, если возможно
p_matlast = True
p_matnum = -1
p_renum = False ' Перенумерация, иначе - только выравнивание
p_slen = 0 ' Длина параметра, задающего p_start. Будет исп. как длина поля
p_start = 0 ' Стартовое значение при перенумерации
p_step = 1 ' Шаг нумерации
p_firstf = False ' Взять начальный номер из первого обрабатываемого файла
p_mask = "*" ' Маска файлов
p_files = True ' Обрабатывать только файлы
p_folders = False ' Обрабатывать только папки
Dim f1, f2, fn1, fn2, fx, fxx
Dim f, fc
Dim fa()
Dim ne, nf, nd, na, nn ' Счётчики
ne = 0 ' Счётчик ошибок
nf = 0 ' Счётчик обработанных файлов
nd = 0 ' Счётчик описаний
na = 0 ' Счётчик найденных имён файлов
nn = 0 ' Счётчик перенумерации
' Разбор аргументов командной строки
Set args = WScript.Arguments
If args.Count = 0 Then
HELP
WScript.Quit
End If
For Each a In args
au = UCase(a)
If Left(au,1) = "/" Then
au = Mid(au,2)
End If
a1 = Left(au,1)
a_int = IsInt(Mid(au,2))
If a_int Then
a_val = CLng(Mid(au,2))
End If
Select Case au
Case "Q"
p_quiet = 2
p_pause = False
Case "Q1"
' Вывести только результирующую информацию
p_quiet = 1
Case "Q2"
' Без паузы
p_pause = False
Case "T"
' Тестирование (вывод результатов без реального переименования)
p_test = True
Case "ND"
' Не обрабатывать descript.ion
p_descr = False
Case "NA"
' Не выравнивать при перенумерации
p_align = False
Case "ML","LM"
' Последнее совпадение
p_matlast = True
'p_matnum = -1
Case "F"
' Обрабатывать только папки
p_files = False
p_folders = True
Case "FF"
' Брать начальный номер из первого обрабатываемого файла
If p_renum Then
' Конфликт параметров
HELP
ERRQ -1
End If
p_firstf = True
p_renum = True
Case Else
If a1 = "A" And a_int Then
' align - выравнивание поля (дополнение нулями)
p_field = a_val
p_align = True
If p_field = 0 Then
HELP
ERRQ -1
End If
ElseIf a1 = "M" And a_int Then
p_matnum = a_val
p_matlast = False
If p_matnum = 0 Then
HELP
ERRQ -1
End If
ElseIf a1 = "S" And a_int Then
' Шаг нумерации
p_step = a_val
If p_step = 0 Then
HELP
ERRQ -1
End If
ElseIf InStr(au,"*")>0 Or InStr(au,"?")>0 Then
' Файлы по маске
p_mask = a
ElseIf IsInt(au) And Not p_firstf Then
' Если число - начальное значение для перенумерации,
' либо шаг перенумерации, если начальное число уже задано,
' но в случае параметра /FF - ошибка
If Not p_renum Then
p_renum = True
p_start = CLng(au)
p_slen = Len(au)
If p_slen > 1 And Left(au,1) = "0" Then
p_field = p_slen
p_align = True
End If
Else
p_step = CLng(au)
If p_step = 0 Then
HELP
ERRQ -1
End If
End If
Else
' Неправильный параметр
HELP
ERRQ -1
End If
End Select
Next
rex.Pattern = "(\d+)"
rex.IgnoreCase = True
rex.Global = True
' Чтение описаний
Dim des
If p_descr Then
Set des = New descr
des.load
End If
' Проверка ширины поля
If p_renum Then
If p_field < p_slen Then
p_field = p_slen
End If
End If
If p_folders Then
' Обработка папок
nn = p_start
na = 0
Set fc = shap.NameSpace(shl.CurrentDirectory).Items()
fc.Filter 32, p_mask
For Each f1 In fc
If rex.Test(f1) Then
' Если есть число - в массив для дальнейшей обработки
ReDim Preserve fa(na)
fa(na) = f1
na = na+1
End If
Next
If na Then
For Each f1 In fa
Set mats = rex.Execute(f1)
If mats.Count > 0 Then
If p_matlast Then
matn = mats.Count-1
Else
matn = p_matnum-1
End If
If matn < mats.Count Then
f2 = f1
matv = mats(matn).Value
matl = Len(matv)
matp = mats(matn).FirstIndex
If p_firstf Then
' Взять начальный счётчик из имени файла
nn = matv
p_firstf = False
End If
If p_renum Then
' При перенумерации используем счётчик
newv = CStr(nn)
If p_field > Len(newv) And p_align Then
' Выравнивание найденного числа если его длина меньше длины заданного поля.
newv = Right(String(p_field,"0")&newv,p_field)
End If
Else
' При простом выравнивании используем старое значение
newv = matv
If Not p_align Then
newv = newv+0
ElseIf p_field > matl Then
' Дополнение нулями
newv = Right(String(p_field,"0")&newv,p_field)
ElseIf p_field > 0 Then
' Усечение
newv = Right(newv,p_field)
End If
End If
f2 = Left(f2,matp) & newv & Mid(f2,matp+matl+1)
If f1 <> f2 Then
' Папка требует переименования
If p_quiet = 0 Then
WScript.Echo f1
WScript.Echo "-> " & f2
End If
nf = nf+1
If Not p_test Then
Err.Clear
fso.MoveFolder f1, f2
'Set ff = fso.GetFolder(f1)
'Err.Clear
'ff.Name = f2
If Err.Number <> 0 Then
ne = ne+1
ERRW
ElseIf p_descr Then
des.move f1, f2
End If
ElseIf Len(des.getx(f1)) Then
nd = nd+1
End If
End If
' Чтобы не было пропусков, номер увеличиваем всегда
nn = nn + p_step
End If
End If
Next
End If
End If
If p_files Then
' Обработка файлов
nn = p_start
na = 0
Set fc = shap.NameSpace(shl.CurrentDirectory).Items()
fc.Filter 64, p_mask
For Each f1 In fc
x = InStrRev(f1,".")
If x > 1 Then
fn1 = Left(f1,x-1)
fx = Mid(f1,x)
Else
fn1 = f1
fx = ""
End If
If rex.Test(fn1) Then
' Если есть число - в массив для дальнейшей обработки
ReDim Preserve fa(na)
fa(na) = f1
na = na+1
End If
Next
If na Then
For Each f1 In fa
' Для файлов исключаем расширение из обработки
x = InStrRev(f1,".")
If x>1 Then
fn1 = Left(f1,x-1)
fx = Mid(f1,x)
Else
fn1 = f1
fx = ""
End If
Set mats = rex.Execute(fn1)
If mats.Count > 0 Then
If p_matlast Then
matn = mats.Count-1
Else
matn = p_matnum-1
End If
If matn < mats.Count Then
fn2 = fn1
matv = mats(matn).Value
matl = Len(matv)
matp = mats(matn).FirstIndex
If p_firstf Then
' Взять начальный счётчик из имени файла
nn = matv
p_firstf = False
End If
If p_renum Then
' При перенумерации используем счётчик
newv = CStr(nn)
If p_field > Len(newv) And p_align Then
' Выравнивание найденного числа если его длина меньше длины заданного поля.
newv = Right(String(p_field,"0")&newv,p_field)
End If
Else
' При простом выравнивании используем старое значение
newv = matv
If Not p_align Then
newv = newv+0
ElseIf p_field > matl Then
' Дополнение нулями
newv = Right(String(p_field,"0")&newv,p_field)
ElseIf p_field > 0 Then
' Усечение
newv = Right(newv,p_field)
End If
End If
fn2 = Left(fn2,matp) & newv & Mid(fn2,matp+matl+1)
f2 = fn2 & fx
If fn1 <> fn2 Then
' Файл требует переименования
If p_quiet = 0 Then
WScript.Echo f1
WScript.Echo "-> " & f2
End If
nf = nf+1
If Not p_test Then
Err.Clear
fso.MoveFile f1, f2
'Set ff = fso.GetFile(f1)
'Err.Clear
'ff.Name = f2
If Err.Number <> 0 Then
ne = ne+1
ERRW
ElseIf p_descr Then
des.move f1, f2
End If
ElseIf Len(des.getx(f1)) Then
nd = nd+1
End If
End If
' Чтобы не было пропусков, номер увеличиваем всегда
nn = nn + p_step
End If
End If
Next
End If
End If
If p_quiet < 2 Then
WScript.Echo "FOUND: " & nf
WScript.Echo "ERRORS: " & ne
End If
If p_descr Then
If Not p_test Then
nd = des.dc
End If
des.save
If p_quiet < 2 Then
WScript.Echo "DESCR: " & nd
End If
End If
If p_pause Then
WScript.StdOut.Write "Press ENTER key to continue . . ."
x = WScript.StdIn.Read(1)
End If
WScript.Quit ne
'----------------------------------------------------------------------------------------------------------
Sub HELP
WScript.Echo "Using:"
WScript.Echo " vrenum [options] [mask] start [step]"
WScript.Echo " - renum from start number"
WScript.Echo "or"
WScript.Echo " vrenum [options] [mask] [/]FF [[/]S#]"
WScript.Echo " - get start number from first file and renum"
WScript.Echo "or"
WScript.Echo " vrenum [options] [mask] [/]A#"
WScript.Echo " - align numbers"
WScript.Echo "where:"
WScript.Echo " mask - file masks separated by ';' character"
WScript.Echo " samples:"
WScript.Echo " *.jpg"
WScript.Echo " *.doc;*.docx;readme.*"
WScript.Echo " start - start number for renum"
WScript.Echo " step - step for renum,"
WScript.Echo "options:"
WScript.Echo " [/]Q - quiet (no output)"
WScript.Echo " [/]Q1 - output only result info"
WScript.Echo " [/]Q2 - without pause"
WScript.Echo " [/]S# - renum step, default 1"
WScript.Echo " [/]F - rename folders only"
WScript.Echo " [/]A# - align field"
WScript.Echo " [/]NA - no align"
WScript.Echo " [/]M# - match number, default last"
WScript.Echo " [/]ML - last match"
WScript.Echo " [/]ND - not porcess descript.ion"
WScript.Echo " [/]T - testing without real rename"
End Sub
'----------------------------------------------------------------------------------------------------------
' Проверить, что это целое число
Function IsInt( s )
Dim i, l
l = Len(s)
IsInt = False
If l Then
IsInt = True
For i=1 To l
If InStr("0123456789",Mid(s,i,1)) = 0 Then
IsInt = False
Exit For
End If
Next
End If
End Function
'----------------------------------------------------------------------------------------------------------
Sub ERRQ( cod )
If Err.Number <> 0 Then
ERRW
If cod Then
WScript.Quit cod
End If
End If
End Sub
'----------------------------------------------------------------------------------------------------------
Sub ERRW
If p_quiet = 0 Then
WScript.Echo "!! ERROR: " & CStr(Err.Number) & " - " & Err.Description
End If
End Sub
'==========================================================================================================
' Класс для работы с descript.ion
' ver. 2.05.B (без setpath,setx)
'----------------------------------------------------------------------------------------------------------
Class descr
Public da
Public dc
Public dfp ' description file path
'----------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize
dfp = "descript.ion"
ReDim da(1,0)
da(0,0) = ""
da(1,0) = ""
End Sub
'----------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate
ReDim da(0)
dfp = Null
End Sub
'----------------------------------------------------------------------------------------------------------
Public Sub load
dc = 0 ' Счётчик изменений сразу сбрасываем, типа, изменений ещё не было
Dim s, x, fn, ft
Dim i : i = 0
Dim h
With CreateObject("Scripting.FileSystemObject")
If Not .FileExists(dfp) Then
Exit Sub
End If
Set h = .OpenTextFile(dfp,1) ' ForReading
Do While Not h.AtEndOfStream
i = i+1
ReDim Preserve da(1,i)
s = Trim(h.ReadLine)
If Left(s,1) = """" Then
' Имя в кавычках, ищем завершающие кавычки
x = InStr(2,s,"""")
If x Then
fn = Mid(s,2,x-2)
ft = LTrim(Mid(s,x+1))
Else
fn = s
ft = ""
End If
Else
' Имя не в кавычках, ищем пробел
x = InStr(s," ")
If x Then
fn = Left(s,x-1)
ft = LTrim(Mid(s,x+1))
Else
fn = s
ft = ""
End If
End If
' Если строка неправильная, ft бедет пустым
da(0,i) = fn
da(1,i) = ft
Loop
h.Close
End With
End Sub
'----------------------------------------------------------------------------------------------------------
Public Function getx( f )
Dim i
Dim u : u = UBound(da,2)
Dim fu : fu = UCase(f)
If Len(f) Then
' Описания просматриваем с конца, так как действительным является последнее.
For i=u To 0 Step -1
If fu = UCase(da(0,i)) Then
getx = da(1,i)
Exit Function
End If
Next
End If
getx = ""
End Function
'----------------------------------------------------------------------------------------------------------
Public Sub move( f1, f2 )
Dim i
Dim fud
Dim fu1 : fu1 = UCase(f1)
Dim fu2 : fu2 = UCase(f2)
Dim fnd : fnd = False
Dim u : u = UBound(da,2)
If Len(f2) Then
' Переименование
' Описания просматриваем с конца, так как действительным является последнее.
' Если будут дубляжи f1 - пропускаем.
' Если будут дубляжи f2 - удаляем.
For i=u To 0 Step -1
fud = UCase(da(0,i))
If fud = fu1 Then
' Меняем имя файла
' Но только один раз
If Not fnd Then
da(0,i) = f2
dc = dc+1
fnd = True
End If
ElseIf fud = fu2 Then
' Удаляем имя и описание
' Но только если переименование уже было
If fnd Then
da(0,i) = ""
da(1,i) = ""
End If
End If
Next
Else
' Удаление
For i=0 To u
fud = UCase(da(0,i))
If fud = fu1 Then
' Удаляем имя и описание
da(0,i) = ""
da(1,i) = ""
dc = dc+1
End If
Next
End If
End Sub
'----------------------------------------------------------------------------------------------------------
Public Sub save
If dc = 0 Then
' Если не было изменений нефиг и записывать
Exit Sub
End If
Dim u : u = UBound(da,2)
Dim h
Dim i, s, d0, d1
Dim n : n = 0
With CreateObject("Scripting.FileSystemObject")
Set h = .OpenTextFile(dfp,2,Not .FileExists(dfp)) ' ForWriting
For i=0 To u
d0 = da(0,i)
d1 = da(1,i)
If Len(d0) Then
' Не пустое имя файла
If Len(d1) Then
' Это была правильная строка
If InStr(d0," ") Then
s = """" & d0 & """ " & d1
Else
s = d0 & " " & d1
End If
Else
' Это была неправильная строка
s = d0
End If
h.WriteLine( s )
n = n+1
End If
Next
dc = 0 ' Изменений больше нет
h.Close
If n = 0 Then
' Файл пустой
.DeleteFile dfp, True
Else
Set h = .GetFile(dfp)
h.Attributes = 34
End If
End With
End Sub
'----------------------------------------------------------------------------------------------------------
End Class
'==========================================================================================================
