Второй скрипт.
Версия с дополнительной фильтрацией по маске файлов/папок.
Также может добавлять произвольный текст в начало и/или в конец имени, без обработки файлов/папок регулярными выражениями.
' Переименование файлов с использование регулярных выражений
' Расширения файлов не изменяются!
' Для папок, в отличии от файлов, расширения не имеют для системы значения, поэтому их имена обрабатываются целиком.
' 2011.07.31 - v.3.05
' На основе vrenn.vbs (нумерация версий та же)
' Отличия - первый параметр - маска файлов
Option Explicit
On Error Resume Next
Dim x
Dim fso, shl, rex, mat, shap
Set fso = CreateObject("Scripting.FileSystemObject")
Set shl = CreateObject("WScript.Shell")
Set rex = New RegExp
Set shap = CreateObject("Shell.Application")
' Аргументы
Dim p_xn, p_mask, p_find, p_with
Dim p_quiet, p_pause, p_test
Dim p_sens, p_glob, p_descr
Dim p_prefix, p_suffix
Dim p_files, p_folders
Dim p_move, p_m_c, p_dest
p_xn = 0
p_mask = ""
p_find = "" ' Что ищем
p_with = "" ' На что меняем
p_quiet = 0
p_pause = True
p_test = False
p_sens = False
p_glob = True
p_descr = True
p_files = True
p_folders = False
p_prefix = ""
p_suffix = ""
p_move = False
p_m_c = False
p_dest = ""
Dim a, au, args
If WScript.Arguments.Count = 0 Then
HELP
WScript.Quit
End If
' Разбор аргументов командной строки с именами
Set args = WScript.Arguments.Named
If args.Exists("Q") Then
p_quiet = 2
p_pause = False
End If
If args.Exists("Q1") Then
' Вывести только результирующую информацию
p_quiet = 1
End If
If args.Exists("Q2") Then
' Без паузы
p_pause = False
End If
If args.Exists("T") Then
' Тестирование (вывод результатов без реального переименования)
p_test = True
End If
If args.Exists("CS") Then
' case sense
p_sens = True
End If
If args.Exists("ND") Then
p_descr = False
End If
If args.Exists("1") Then
' Только одну замену в имени
p_glob = False
End If
If args.Exists("F") Then
' Обрабатывать только папки
p_files = False
p_folders = True
End If
If args.Exists("FF") Then
' Обрабатывать и файлы и папки
p_files = True
p_folders = True
End If
If args.Exists("P") Then
' Префикс - добавить произвольный текст в начало имени
p_prefix = args.Item("P")
End If
If args.Exists("S") Then
' Суффикс - добавить произвольный текст в конец имени
p_suffix = args.Item("S")
End If
If args.Exists("M") Then
' MOVE - переместить в папку
p_move = True
p_m_c = True
p_dest = args.Item("M")
End If
If args.Exists("C") Then
' COPY - копировать в папку
p_move = False
p_m_c = True
p_dest = args.Item("C")
End If
' Разбор аргументов командной строки без имён
Set args = WScript.Arguments.Unnamed
For Each a In args
au = UCase(Left(a,2))
If p_xn < 1 Then
' маска
p_mask = a
p_xn = 1
ElseIf p_xn < 2 Then
' регулярное выражение
p_find = a
p_xn = 2
ElseIf p_xn < 3 Then
' строка замены
If a = "\" Then ' Пустая строка
a = ""
End If
p_with = a
p_xn = 3
Else
' Неправильный параметр
HELP
WScript.Echo "ERROR: -1"
WScript.Quit -1
End If
Next
If p_xn = 1 And (Len(p_prefix)+Len(p_suffix)) > 0 Then
' Задана только маска файлов, но при этом задан суффикс и/или префикс
' Поэтому задаём фиктивные патерн и замену
p_find = "(.)"
p_with = "$1"
p_glob = False
p_xn = 3
End If
If p_xn < 3 Or Len(p_find) = 0 Then
' Недостаточно аргументов
' или пустой патерн
HELP
WScript.Echo "ERROR: -2"
WScript.Quit -2
End If
rex.Pattern = p_find
rex.IgnoreCase = Not p_sens
rex.Global = p_glob
' Проверка правильности регулярного выражения
Err.Clear
rex.Test("A")
ERRQ -4
' Чтение описаний
Dim des
If p_descr Then
Set des = New descr
des.load
End If
' Папка назначения при перемещении или копировании
Dim ddes
If p_m_c Then
If Len(p_dest) = 0 Then
HELP
WScript.Quit -1
End If
If Right(p_dest,1)="\" Then
p_dest = Left(p_dest,Len(p_dest)-1)
End If
If Not p_test Then
If Not fso.FolderExists(p_dest) Then
Err.Clear
fso.CreateFolder p_dest
ERRQ -5
End If
Set ddes = New descr
ddes.setpath p_dest
ddes.load
End If
p_dest = p_dest & "\"
End If
Dim f1, f2, fn1, fn2, fx, fxx
Dim ne, nf, nd, na ' Счётчики
Dim f, ff, fc
Dim fa()
ne = 0
nf = 0
nd = 0
' [?] Обязательно ли дублировать Set fc ?
' Т.е., изменится ли список для файлов после переименования папок?
' Set fc = shap.NameSpace(shl.CurrentDirectory).Items()
If p_folders Then
' Обработка папок
na = 0
Set fc = shap.NameSpace(shl.CurrentDirectory).Items()
fc.Filter 32, p_mask
For Each f In fc
f1 = f
' Set mat = rex.Execute(f1)
' If mat.count Then
If rex.Test(f1) Then
If p_xn = 2 Then
' Вывод списка
WScript.Echo f1
nf = nf+1
Else
' В массив для переименования
ReDim Preserve fa(na)
fa(na) = f1
na = na+1
End If
End If
Next
If na Then
If Not p_m_c Then
For Each f1 In fa
f2 = p_prefix & Trim(rex.Replace(f1,p_with)) & p_suffix
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
Next
Else ' move or copy
For Each f1 In fa
If p_quiet = 0 Then
WScript.Echo f1
'WScript.Echo "-> " & p_dest
End If
nf = nf+1
If Not p_test Then
Err.Clear
If p_move Then
fso.MoveFolder f1, p_dest
Else
fso.CopyFolder f1, p_dest
End If
If Err.Number <> 0 Then
ne = ne+1
ERRW
ElseIf p_descr Then
x = des.getx(f1)
If p_move Then
des.setx f1, ""
End If
ddes.setx f1, x
End If
ElseIf Len(des.getx(f1)) Then
nd = nd+1
End If
Next
End If
End If
End If
If p_files Then
' Обработка файлов
na = 0
Set fc = shap.NameSpace(shl.CurrentDirectory).Items()
fc.Filter 64, p_mask
For Each f In fc
f1 = f
x = InStrRev(f1,".")
If x>1 Then
fn1 = Left(f1,x-1)
fx = Mid(f1,x)
Else
fn1 = f1
fx = ""
End If
' Set mat = rex.Execute(fn1)
' If mat.count Then
If rex.Test(fn1) Then
If p_xn = 2 Then
' Вывод списка
WScript.Echo f1
nf = nf+1
Else
' В массив для переименования
ReDim Preserve fa(na)
fa(na) = f1
na = na+1
End If
End If
Next
If na Then
If Not p_m_c Then
For Each f1 In fa
x = InStrRev(f1,".")
If x>1 Then
fn1 = Left(f1,x-1)
fx = Mid(f1,x)
fxx = UCase(Mid(f1,x+1))
Else
fn1 = f1
fx = ""
fxx = ""
End If
fn2 = p_prefix & Trim(rex.Replace(fn1,p_with)) & p_suffix
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(x) Then
nd = nd+1
End If
End If
Next
Else ' move or copy
For Each f1 In fa
If p_quiet = 0 Then
WScript.Echo f1
'WScript.Echo "-> " & p_dest
End If
nf = nf+1
If Not p_test Then
Err.Clear
If p_move Then
fso.MoveFile f1, p_dest
Else
fso.CopyFile f1, p_dest
End If
If Err.Number <> 0 Then
ne = ne+1
ERRW
ElseIf p_descr Then
x = des.getx(f1)
If p_move Then
des.setx f1, ""
End If
ddes.setx f1, x
End If
ElseIf Len(des.getx(f1)) Then
nd = nd+1
End If
Next
End If
End If
End If
If p_quiet < 2 Then
WScript.Echo "FOUND: " & nf
If p_xn > 2 Or p_m_c Then
' Если не вывод списка, а переименование/перемещение/копирование
WScript.Echo "ERRORS: " & ne
End If
End If
If p_descr Then
If p_m_c Then
ddes.save
End If
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 " vrenm mask patern"
WScript.Echo " - list"
WScript.Echo "or"
WScript.Echo " vrenm [options] mask patern replace"
WScript.Echo " - rename"
WScript.Echo "or"
WScript.Echo " vrenm [options] mask patern /M:folder"
WScript.Echo " - move to folder"
WScript.Echo "or"
WScript.Echo " vrenm [options] mask patern /C:folder"
WScript.Echo " - copy to folder"
WScript.Echo "where:"
WScript.Echo " mask - file masks separated by ';' character"
WScript.Echo " samples:"
WScript.Echo " *.jpg"
WScript.Echo " *.doc;*.docx;readme.*"
WScript.Echo " patern - regular expression patern (sintax is wsh)"
WScript.Echo " replace - regular expression replace (sintax is wsh)"
WScript.Echo "options:"
WScript.Echo " /Q - quiet (no output)"
WScript.Echo " /Q1 - output only result info"
WScript.Echo " /Q2 - without pause"
WScript.Echo " /F - rename folders only"
WScript.Echo " or"
WScript.Echo " /FF - rename folder and files"
WScript.Echo " otherwise rename files only"
WScript.Echo " /CS - case sensifity"
WScript.Echo " /1 - only one match (otherwise all matches)"
WScript.Echo " /P:$ - add prefix to name"
WScript.Echo " /S:$ - add suffix to name"
WScript.Echo " /ND - not porcess descript.ion"
WScript.Echo " /T - testing regular expression without real rename"
End Sub
'----------------------------------------------------------------------------------------------------------
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
'----------------------------------------------------------------------------------------------------------
Class descr
Public da
Public dc
Public dfp ' description full path
'----------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize
setpath ""
ReDim da(1,0)
da(0,0) = ""
da(1,0) = ""
End Sub
'----------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate
da = Null
dfp = Null
End Sub
'----------------------------------------------------------------------------------------------------------
Public Sub setpath( p )
With CreateObject("Scripting.FileSystemObject")
If Len(p) = 0 Then
dfp = .GetAbsolutePathName("descript.ion")
Else
dfp = .GetAbsolutePathName(p & "\descript.ion")
End If
End With
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 setx( f, d )
' Нужно ли удаление дубликатов?
' Нужен ли trim для описаний?
Dim i
Dim u : u = UBound(da,2)
Dim fu : fu = UCase(f)
If Len(d) Then
' Присваивание
' Описания просматриваем с конца, так как действительным является последнее.
dc = dc+1 ' Изменения всегда будут
For i=u To 0 Step -1
If UCase(da(0,i)) = fu Then
' Меняем описание и завершаем функцию
da(1,i) = d
Exit Sub
End If
Next
' Добавляем описание
i = u+1
ReDim Preserve da(1,i)
da(0,i) = f
da(1,i) = d
Else
' Удаление
For i=u To 0 Step -1
If UCase(da(0,i)) = fu Then
' Удаляем имя и описание и завершаем функцию
da(0,i) = ""
da(1,i) = ""
dc = dc+1
Exit Sub
End If
Next
End If
End Sub
'----------------------------------------------------------------------------------------------------------
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 i, s, d0, d1
Dim n : n = 0 ' Счётчик записанных строк
Dim h
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
'==========================================================================================================
).
