1 (изменено: Smitis, 2011-08-29 00:20:31)

Тема: VBScript: Переименование файлов с использованием регулярных выражений

Переименование файлов с использованием регулярных выражений из командной строки или других скриптов.
Для запуска использовать cscript.
- Формат регулярных выражений VBS.
- Папки не обрабатываются, только файлы.
- Обрабатываются только имена файлов, расширения игнорируются (т.е. не обрабатываются и остаются прежними).
- Файлы обрабатываются только в текущей папке, без обхода подпапок.
- Код возврата - количество переименованных файлов (0 - переименований не было) или -1 (2147483647) в случае ошибки в параметрах.

Скрипт vrenn.vbs

' Переименование файлов с использование регулярных выражений
' Расширения файлов не изменяются!
' v.2.00.sc (for ScriptCoding)

Option Explicit
On Error Resume Next

Dim x
Dim fso, shl, rex, mat
Dim a, au, args

Set fso = CreateObject("Scripting.FileSystemObject")
Set shl = CreateObject("WScript.Shell")
Set rex = New RegExp

' Разбор аргументов
Dim p_x1, p_x2, p_xn, p_quiet, p_sens, p_exts, p_glob, p_list
Dim q_exts
p_xn = 0
p_quiet = 0
p_sens = False
p_glob = True

' Разбор аргументов командной строки с именами
Set args = WScript.Arguments.Named
If args.Exists("Q") Then
    p_quiet = 2
End If
If args.Exists("Q1") Then
    ' Вывести только результирующую информацию
    p_quiet = 1
End If
If args.Exists("S") Then
    p_sens = True
End If
If args.Exists("X") Then
    ' Если список расширений пуст,
    ' будут использоваться любые расширения
    p_exts = args.Item("X")
End If
If args.Exists("1") Then
    ' Только одну замену в имени
    p_glob = False
End If

' Разбор аргументов командной строки без имён
Set args = WScript.Arguments.Unnamed
For Each a In args
    au = UCase(Left(a,2))
    If p_xn < 1 Then
        p_x1 = a
        p_xn = 1
    ElseIf p_xn < 2 Then
        p_x2 = a
        p_xn = 2
    ElseIf p_xn < 3 Then
        p_exts = a
        p_xn = 3
    Else
        ' Неправильный параметр
        vrenn_help
        WScript.Quit
    End If
Next

If p_xn < 1 Or p_x1 = "" Then
    ' Недостаточно аргументов
    ' или пустой патерн
    vrenn_help
    WScript.Quit
End If

q_exts = Len(p_exts)>0 ' Заданы ли расширения

rex.Pattern = p_x1
rex.IgnoreCase = Not p_sens
rex.Global = p_glob

' Проверка правильности регулярного выражения
Err.Clear
rex.Test("A")
If Err.Number Then
    WScript.Echo "ERROR # " & CStr(Err.Number) & " " & Err.Description
    WScript.Quit 2147483647 ' &H7FFFFFFF
End If

Dim f1, f2, fn1, fn2, fx

Dim ne, nf, na ' Счётчики
Dim f, fc, fa()
ne = 0
nf = 0
na = 0
Set fc = fso.GetFolder(".").Files

For Each f In fc
    f1 = f.Name
    x = InStrRev(f1,".")
    If x>1 Then
        fn1 = Left(f1,x-1)
        fx = Mid(f1,x)
    Else
        fn1 = f1
        fx = ""
    End If
    ' Проверяем расширение файла
    If Not q_exts Or (q_exts And fx<>"" And InStr(p_exts,fx)>0) Then
        Set mat = rex.Execute(fn1)
        If mat.count Then
            If p_xn = 1 Then
                ' Вывод списка
                WScript.Echo f1
                nf = nf+1
            Else
                ' В массив для переименования
                ReDim Preserve fa(na)
                fa(na) = f1
                na = na+1
            End If
        End If
    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
        fn2 = rex.Replace(fn1,p_x2)
        f2 = fn2 & fx
        If fn1 <> fn2 Then
            ' Файл требует переименования
            If Not p_quiet Then
                WScript.Echo f1
                WScript.Echo "-> " & f2
            End If
            nf = nf+1
            Err.Clear
            fso.MoveFile f1, f2
            If Err.Number <> 0 Then
                ne = ne+1
            End If
        End If
    Next
End If

If p_quiet < 2 Then
    WScript.Echo "FOUND:  " & nf
    If p_xn > 1 Then
        WScript.Echo "ERRORS: " & ne
    End If
End If

WScript.Quit ne

Sub vrenn_help()

    WScript.Echo "Using:"
    WScript.Echo "    vrenn [/X:exts|/X|/XX] [/S] patern [exts]"
    WScript.Echo "        or"
    WScript.Echo "    vrenn [/Qjhnmk] [/X:exts|/X|/XX] patern replace [exts]"
    WScript.Echo "        where:"
    WScript.Echo "    /X:exts - extensions separated by ';' character"
    WScript.Echo "    /X      - all extensions"
    WScript.Echo "    /1      - only one match in one name (otherwise all matches)"
    WScript.Echo "    /S      - case sensitive"
    WScript.Echo "    /Q      - quiet"
    WScript.Echo "    /Q1     - quiet (output result only)"
    WScript.Echo ""

End Sub

2 (изменено: Smitis, 2011-05-03 22:25:38)

Re: VBScript: Переименование файлов с использованием регулярных выражений

Выяснился неприятный момент. Переименованный файл может снова оказаться в коллекции и быть повторно обработан. Альтернативный метод переименования изменением свойства Name файла даёт аналогичный результат. Иногда это случается, иногда - нет.
Новая версия сначала создаёт в массиве список файлов, подлежащих переименовании. Не знаю, как это скажется на производительности при большом количестве файлов.

3

Re: VBScript: Переименование файлов с использованием регулярных выражений

Новая версия

Изменения:
- Исключён ключ /X (выбор расширений) за ненадобностью (теперь это делает другой скрипт по маске, к тому же он из-за неточности был регистрозависимым).
- Вместо пустой строки для замены можно ввести один символ \ (быстрее набирать smile ).
- Добавлено переименование только папок (ключ /F) или папок и файлов (ключ /FF)(по умолчанию переименовываются только файлы).
- Обработка описаний из файла descript.ion (в кодировке CP-1251).

vrenn.vbs

' Переименование файлов с использование регулярных выражений
' Расширения файлов не изменяются!
' Для папок, в отличии от файлов, расширения не имеют для системы значения, поэтому их имена обрабатываются целиком.

' v.3.00

Option Explicit
On Error Resume Next

Dim x

Dim fso, shl, rex, mat
Set fso = CreateObject("Scripting.FileSystemObject")
Set shl = CreateObject("WScript.Shell")
Set rex = New RegExp

' Аргументы
Dim p_xn, p_find, p_with
Dim p_quiet, p_sens, p_eni, p_glob, p_descr
Dim p_files, p_folders
p_xn = 0
p_find = "" ' Что ищем
p_with = "" ' На что меняем
p_quiet = 0
p_sens = False
p_eni = False
p_glob = True
p_descr = True
p_files = True
p_folders = False

Dim a, au, args

' Разбор аргументов командной строки с именами
Set args = WScript.Arguments.Named
If args.Exists("Q") Then
    p_quiet = 2
End If
If args.Exists("Q1") Then
    ' Вывести только результирующую информацию
    p_quiet = 1
End If
If args.Exists("S") Then
    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

' Разбор аргументов командной строки без имён
Set args = WScript.Arguments.Unnamed
For Each a In args
    au = UCase(Left(a,2))
    If a = "\" Then
        ' Пустая строка
        a = ""
    End If
    If p_xn < 1 Then
        p_find = a
        p_xn = 1
    ElseIf p_xn < 2 Then
        p_with = a
        p_xn = 2
    Else
        ' Неправильный параметр
        help
        WScript.Quit
    End If
Next

If p_xn < 1 Or p_find = "" Then
    ' Недостаточно аргументов
    ' или пустой патерн
    help
    WScript.Quit -1
End If

rex.Pattern = p_find
rex.IgnoreCase = Not p_sens
rex.Global = p_glob

' Проверка правильности регулярного выражения
Err.Clear
rex.Test("A")
If Err.Number Then
    WScript.Echo "ERROR # " & CStr(Err.Number) & " " & Err.Description
    WScript.Quit -2
End If

' Чтение описаний
Dim des
If p_descr Then
    Set des = New descr
    des.load
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

If p_folders Then
    ' Обработка папок
    na = 0
    Set fc = fso.GetFolder(".").SubFolders
    For Each f In fc
        f1 = f.Name
        If rex.Test(f1) Then
            If p_xn = 1 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
        For Each f1 In fa
            f2 = rex.Replace(f1,p_with)
            If f1 <> f2 Then
                ' Папка требует переименования
                If p_quiet = 0 Then
                    WScript.Echo f1
                    WScript.Echo "-> " & f2
                End If
                nf = nf+1
                Err.Clear
                fso.MoveFolder f1, f2
                'Set ff = fso.GetFolder(f1) ' Другой способ
                'Err.Clear
                'ff.Name = f2
                If Err.Number <> 0 Then
                    ne = ne+1
                    If p_quiet = 0 Then
                        WScript.Echo "!! ERROR: " & CStr(Err.Number) & " - " & Err.Description
                    End If
                ElseIf p_descr Then
                    des.move f1, f2
                End If
            End If
        Next
    End If
End If

If p_files Then
    ' Обработка файлов
    na = 0
    Set fc = fso.GetFolder(".").Files
    For Each f In fc
        f1 = f.Name
        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
            If p_xn = 1 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
        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
            fn2 = rex.Replace(fn1,p_with)
            f2 = fn2 & fx
            If fn1 <> fn2 Then
                ' Файл требует переименования
                If p_quiet = 0 Then
                    WScript.Echo f1
                    WScript.Echo "-> " & f2
                End If
                nf = nf+1
                Err.Clear
                fso.MoveFile f1, f2
                'Set ff = fso.GetFile(f1) ' Другой способ
                'Err.Clear
                'ff.Name = f2
                If Err.Number <> 0 Then
                    ne = ne+1
                    If p_quiet = 0 Then
                        WScript.Echo "!! ERROR: " & CStr(Err.Number) & " - " & Err.Description
                    End If
                ElseIf p_descr Then
                    des.move f1, f2
                End If
            End If
        Next
    End If
End If

If p_quiet < 2 Then
    WScript.Echo "FOUND:  " & nf
    If p_xn > 1 Then
        ' Если не вывод списка, а переименование
        WScript.Echo "ERRORS: " & ne
    End If
End If

If p_descr Then
    nd = des.dc
    des.save
    If p_quiet < 2 Then
        WScript.Echo "DESCR:  " & nd
    End If
End If

WScript.Quit ne

'----------------------------------------------------------------------------------------------------------
Sub Help
    WScript.Echo "Using:"
    WScript.Echo "  vrenn patern"
    WScript.Echo "  - list"
    WScript.Echo "or"
    WScript.Echo "  vrenn [options] patern replace"
    WScript.Echo "  - rename"
    WScript.Echo "where:"
    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 "  /f      - rename folders only"
    WScript.Echo "            or"
    WScript.Echo "  /ff     - rename folder and files"
    WScript.Echo "            otherwise rename files only"
    WScript.Echo "  /s      - case sensifity"
    WScript.Echo "  /1      - only one match (otherwise all matches)"
    WScript.Echo "  /nd     - not porcess descript.ion"
    'WScript.Echo "  /eni    - not ighore file extensions"
End Sub

'==========================================================================================================
' Класс для работы с descript.ion
' ver. 2.01
'----------------------------------------------------------------------------------------------------------

Class descr
    Public da
    Public dc
    Public fso

'----------------------------------------------------------------------------------------------------------

Private Sub Class_Initialize
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Загрузка из файла при создании
    'da.load
End Sub

'----------------------------------------------------------------------------------------------------------

Private Sub Class_Terminate
    Set fso = Nothing
End Sub

'----------------------------------------------------------------------------------------------------------

Public Sub load
    dc = 0 ' Счётчик изменений сразу сбрасываем, типа, изменений ещё не было
    Dim i, u, s, x, fn
    Dim dx      ' промежуточный массив
    Dim dt      ' текст с описаниями
    Dim ft
    Set ft = fso.OpenTextFile("descript.ion",1) ' ForReading
    dt = ft.ReadAll
    dx = Split(dt,vbCrLf)
    dt = Null
    u = UBound(dx)
    ReDim da(1,u)
    For i=0 To u
        s = Trim(dx(i))
        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
    Next
End Sub

'----------------------------------------------------------------------------------------------------------

Public Sub move( f1, f2 )
    Dim i, u : u = UBound(da,2)
    Dim fud
    Dim fu1 : fu1 = UCase(f1)
    Dim fu2 : fu2 = UCase(f2)
    Dim fnd : fnd = False

    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 ft
    Set ft = fso.OpenTextFile("descript.ion",2) ' ForWriting
    Dim i, u, s, d0, d1
    u = UBound(da,2)
    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
            ft.WriteLine( s )
        End If
    Next
    dc = 0 ' Изменений больше нет
End Sub

'----------------------------------------------------------------------------------------------------------

End Class

'==========================================================================================================

4

Re: VBScript: Переименование файлов с использованием регулярных выражений

Версия с дополнительной фильтрацией по маске файлов/папок.
Фильтр имеет обычный вид ДОС маски с использованием метасимволов * и ?
Фильтр обязателен и задаётся первым "безымянным" параметром.
Возможно задание нескольких масок через точку с запятой (*.jpg;*.gif;*.png)
В принципе, метасимволы не обязательны, тогда подразумеваются конкретные имена файлов/папок.

vrenm.vbs

' Переименование файлов с использование регулярных выражений
' Расширения файлов не изменяются!
' Для папок, в отличии от файлов, расширения не имеют для системы значения, поэтому их имена обрабатываются целиком.

' На основе vrenn.vbs (нумерация версий та же)
' Отличия - первый параметр - маска файлов

' v.3.00

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_sens, p_eni, p_glob, p_descr
Dim p_files, p_folders
p_xn = 0
p_mask = ""
p_find = "" ' Что ищем
p_with = "" ' На что меняем
p_quiet = 0
p_sens = False
p_eni = False
p_glob = True
p_descr = True
p_files = True
p_folders = False

Dim a, au, args

' Разбор аргументов командной строки с именами
Set args = WScript.Arguments.Named
If args.Exists("Q") Then
    p_quiet = 2
End If
If args.Exists("Q1") Then
    ' Вывести только результирующую информацию
    p_quiet = 1
End If
If args.Exists("S") Then
    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

' Разбор аргументов командной строки без имён
Set args = WScript.Arguments.Unnamed
For Each a In args
    au = UCase(Left(a,2))
    If a = "\" Then
        ' Пустая строка
        a = ""
    End If
    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
        p_with = a
        p_xn = 3
    Else
        ' Неправильный параметр
        help
        WScript.Quit
    End If
Next

If InStr(p_mask,"*")=0 And InStr(p_mask,"?")=0 Then
    ' Пустая маска
    help
    WScript.Quit -3
End If
If p_xn < 2 Or p_find = "" Then
    ' Недостаточно аргументов
    ' или пустой патерн
    help
    WScript.Quit -1
End If

rex.Pattern = p_find
rex.IgnoreCase = Not p_sens
rex.Global = p_glob

' Проверка правильности регулярного выражения
Err.Clear
rex.Test("A")
If Err.Number Then
    WScript.Echo "ERROR # " & CStr(Err.Number) & " " & Err.Description
    WScript.Quit -2
End If

' Чтение описаний
Dim des
If p_descr Then
    Set des = New descr
    des.load
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

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
        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
        For Each f1 In fa
            f2 = rex.Replace(f1,p_with)
            If f1 <> f2 Then
                ' Папка требует переименования
                If p_quiet = 0 Then
                    WScript.Echo f1
                    WScript.Echo "-> " & f2
                End If
                nf = nf+1
                Err.Clear
                fso.MoveFolder f1, f2
                'Set ff = fso.GetFolder(f1) ' Другой способ
                'Err.Clear
                'ff.Name = f2
                If Err.Number <> 0 Then
                    ne = ne+1
                    If p_quiet = 0 Then
                        WScript.Echo "!! ERROR: " & CStr(Err.Number) & " - " & Err.Description
                    End If
                ElseIf p_descr Then
                    des.move f1, f2
                End If
            End If
        Next
    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
        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
        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 = rex.Replace(fn1,p_with)
            f2 = fn2 & fx
            If fn1 <> fn2 Then
                ' Файл требует переименования
                If p_quiet = 0 Then
                    WScript.Echo f1
                    WScript.Echo "-> " & f2
                End If
                nf = nf+1
                Err.Clear
                fso.MoveFile f1, f2
                'Set ff = fso.GetFile(f1) ' Другой способ
                'Err.Clear
                'ff.Name = f2
                If Err.Number <> 0 Then
                    ne = ne+1
                    If p_quiet = 0 Then
                        WScript.Echo "!! ERROR: " & CStr(Err.Number) & " - " & Err.Description
                    End If
                ElseIf p_descr Then
                    des.move f1, f2
                End If
            End If
        Next
    End If
End If

If p_quiet < 2 Then
    WScript.Echo "FOUND:  " & nf
    If p_xn > 2 Then
        ' Если не вывод списка, а переименование
        WScript.Echo "ERRORS: " & ne
    End If
End If

If p_descr Then
    nd = des.dc
    des.save
    If p_quiet < 2 Then
        WScript.Echo "DESCR:  " & nd
    End If
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 "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 "  /f      - rename folders only"
    WScript.Echo "            or"
    WScript.Echo "  /ff     - rename folder and files"
    WScript.Echo "            otherwise rename files only"
    WScript.Echo "  /s      - case sensifity"
    WScript.Echo "  /1      - only one match (otherwise all matches)"
    WScript.Echo "  /nd     - not porcess descript.ion"
    'WScript.Echo "  /eni    - not ighore file extensions"
End Sub

'==========================================================================================================
' Класс для работы с descript.ion
' ver. 2.01
'----------------------------------------------------------------------------------------------------------

Class descr
    Public da
    Public dc
    Public fso

'----------------------------------------------------------------------------------------------------------

Private Sub Class_Initialize
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Загрузка из файла при создании
    'da.load
End Sub

'----------------------------------------------------------------------------------------------------------

Private Sub Class_Terminate
    Set fso = Nothing
End Sub

'----------------------------------------------------------------------------------------------------------

Public Sub load
    dc = 0 ' Счётчик изменений сразу сбрасываем, типа, изменений ещё не было
    Dim i, u, s, x, fn
    Dim dx      ' промежуточный массив
    Dim dt      ' текст с описаниями
    Dim ft
    Set ft = fso.OpenTextFile("descript.ion",1) ' ForReading
    dt = ft.ReadAll
    dx = Split(dt,vbCrLf)
    dt = Null
    u = UBound(dx)
    ReDim da(1,u)
    For i=0 To u
        s = Trim(dx(i))
        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
    Next
End Sub

'----------------------------------------------------------------------------------------------------------

Public Sub move( f1, f2 )
    Dim i, u : u = UBound(da,2)
    Dim fud
    Dim fu1 : fu1 = UCase(f1)
    Dim fu2 : fu2 = UCase(f2)
    Dim fnd : fnd = False

    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 ft 
    Set ft = fso.OpenTextFile("descript.ion",2) ' ForWriting
    Dim i, u, s, d0, d1
    u = UBound(da,2)
    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
            ft.WriteLine( s )
        End If
    Next
    dc = 0 ' Изменений больше нет
End Sub

'----------------------------------------------------------------------------------------------------------

End Class

'==========================================================================================================

5

Re: VBScript: Переименование файлов с использованием регулярных выражений

Очередное усовершенствование.

- Изменён ключ, всключающий чуствительность к регистру с /S на /CS (Case Sense)
- В начало и в конец имени можно добавлять произвольный текст (ключ /P - префикс и /S - суффикс). Причём второй скрипт, vrenm, может работать без обработки имён регулярными выражениями (патерн и замена опущены), толко добавляя префикс и/или суффикс.
- После обработки регулярного выражения от имени отбрасываются лидирующие и завершающие пробелы.
- Вывод сообщений об ошибках.
- Вместо переименования можно выполнить перенос (/M - move) или копирование (/C - copy) в другую папку.
- Пауза в конце обработки.
- Доработан алгоритм обработки descript.ion
- Режим тестирования для проверки регулярных выражений без реального переименования.

vrenn.vbs

' Переименование файлов с использование регулярных выражений
' Расширения файлов не изменяются!
' Для папок, в отличии от файлов, расширения не имеют для системы значения, поэтому их имена обрабатываются целиком.

' 2011.07.31 - v.3.05

Option Explicit
On Error Resume Next

Dim x

Dim fso, shl, rex, mat
Set fso = CreateObject("Scripting.FileSystemObject")
Set shl = CreateObject("WScript.Shell")
Set rex = New RegExp

' Аргументы
Dim p_xn, 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_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_find = a
        p_xn = 1
    ElseIf p_xn < 2 Then
        ' строка замены
        If a = "\" Then ' Пустая строка
            a = ""
        End If
        p_with = a
        p_xn = 2
    Else
        ' Неправильный параметр
        HELP
        WScript.Echo "ERROR: -1"
        WScript.Quit -1
    End If
Next

If p_xn < 1 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

If p_folders Then
    ' Обработка папок
    na = 0
    Set fc = fso.GetFolder(".").SubFolders
    For Each f In fc
        f1 = f.Name
        'Set mat = rex.Execute(f1)
        'If mat.count Then
        If rex.Test(f1) Then
            If p_xn = 1 And Not p_m_c 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 = fso.GetFolder(".").Files
    For Each f In fc
        f1 = f.Name
        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 = 1 And Not p_m_c 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)
                Else
                    fn1 = f1
                    fx = ""
                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(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.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 > 1 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 "  vrenn patern"
    WScript.Echo "  - list"
    WScript.Echo "or"
    WScript.Echo "  vrenn [options] patern replace"
    WScript.Echo "  - rename"
    WScript.Echo "or"
    WScript.Echo "  vrenn [options] patern [/M:folder]"
    WScript.Echo "  - move to folder"
    WScript.Echo "or"
    WScript.Echo "  vrenn [options] patern [/C:folder]"
    WScript.Echo "  - copy to folder"
    WScript.Echo "where:"
    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

'==========================================================================================================

6

Re: VBScript: Переименование файлов с использованием регулярных выражений

Второй скрипт.
Версия с дополнительной фильтрацией по маске файлов/папок.
Также может добавлять произвольный текст в начало и/или в конец имени, без обработки файлов/папок регулярными выражениями.

vrenm.vbs

' Переименование файлов с использование регулярных выражений
' Расширения файлов не изменяются!
' Для папок, в отличии от файлов, расширения не имеют для системы значения, поэтому их имена обрабатываются целиком.

' 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

'==========================================================================================================

7

Re: VBScript: Переименование файлов с использованием регулярных выражений

Развитие скрипта получило продолжение уже в виде исполняемого файла
http://www.cyberforum.ru/cmd-bat/thread1226601.html