'========================= VBS ==========================
' Переименовать файлы внутри выбранных папок по их именам
' при включении алфавитной сортировки (по умолч. прямой)
' Параметры: %WL
' необязат.: <фильтр-список расширений>
' <cортировка обратная: 1>
' Примеры: %WL
' %WL *.jpg;*.jpeg 1
'========================================================
Const Rank = 2 ' Минимальное число цифр в именах копий
'========================================================
With WSH.Arguments
C = .Count : If C = 0 Then WSH.Quit
List = .Item(0) : If C > 1 Then Filt = .Item(1)
If Filt = "" Then Filt = "*.*"
If C = 2 Then Sort = .Item(2)
End With : Set ShA = CreateObject("Shell.Application")
Set Lst = CreateObject("System.Collections.ArrayList")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Reg = New RegExp : Reg.IgnoreCase = True
Set Rgx = New RegExp : Rgx.Global = True
Rgx.Pattern = "([()+.[^{$])"
With FSO.OpenTextFile(List,,,-1)
Do : P = Trim(.ReadLine)
If FSO.FolderExists(P) Then
Set Path = ShA.NameSpace(P)
Set Items = Path.Items
Items.Filter 73952, Filt
If Items.Count Then
For Each F in Items
If FSO.FileExists(F.Path) Then Lst.Add CStr(F)
Next : i = 1 : Lst.Sort : If Sort = 1 Then Lst.Reverse
For Each F in Lst
Ext = FSO.GetExtensionName(F)
Reg.Pattern = "^" & Rgx.Replace(_
Path.Title, "\$1") & " \(\d+\)\.?" & Ext & "$"
If Not Reg.Test(F) Then
If Len(Ext) Then Ext = "." & Ext
FP = P & Path.Title : FN = FP & " (" & R(1) & ")" & Ext
While FSO.FileExists(FN) Or FSO.FolderExists(FN)
i = i + 1 : FN = FP & " (" & R(i) & ")" & Ext
Wend
FSO.GetFile(P & F).Name = Path.Title & " (" & R(i) & ")" & Ext
End If
Next : Lst.Clear
End If
End If
Loop Until .AtEndOfStream : .Close
End With
MsgBox Space(18) & "Выполнено!", 4160,_
" Переименование файлов внутри папок "
Function R(n) R = Right(String(Rank, "0") & n, Rank) End Function |