'=================== VBS ===================
' Переместить файлы из каталога под курсором
' в папки с именами соответствующих им масок
' Параметр: %V
'===========================================
Option Explicit : Dim Filt, Fold, Rgx, REx, FSO, File,_
Strm, List, TName, Mask, IPath, OPath, FPath, IsMask, c
'===================== Маски файлов через "|" =====================
Filt = "12*.*|name 1.txt|name 1*.txt|name *1.*|name2.txt|2.txt|" &_
"name 2.txt|name *2.txt|name 2*.*|name 2.*|name*.txt|*name*|*2*" &_
"|name 3.*|name3.txt|*3*.txt|name 4.txt|name *4*.txt|*5*.txt|*5*"
'==================================================================
Fold = WSH.Arguments(0)
Set Rgx = New RegExp : Rgx.Global = True
Rgx.MultiLine = True : Rgx.IgnoreCase = True
Set REx = New RegExp : REx.Pattern = "([?[\]}{.^$+\-])"
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO
If Not .FolderExists(LP(Fold)) Then WSH.Quit
Set Strm = CreateObject("SAPI.SpFileStream")
For Each File in .GetFolder("\\?\" & Fold).Files
List = List & vbLf & .GetFileName(File)
Next
TName = .GetBaseName(.GetTempName)
For Each Mask in Split(Filt, "|")
Rgx.Pattern = "^" & Replace(REx.Replace(Mask, "\$1"), "*", ".*") & "$"
If Rgx.Test(List) Then
OPath = LP(.BuildPath(Fold, Replace(Mask, "*", ChrW(-246))))
IsMask = InStr(OPath, ChrW(-246))
For Each File in Rgx.Execute(List)
IPath = LP(.BuildPath(Fold, File))
If .FileExists(IPath) Then
If IsMask = 0 Then
If Left(IPath, 1) <> "\" Then
.GetFile(IPath).Name = File & TName
Else CreateForLong IPath, LP(IPath & TName) End If
IPath = LP(IPath & TName)
End If
If Not .FolderExists(OPath) Then .CreateFolder OPath
FPath = LP(.BuildPath(OPath, File)) : c = 2
While FSO.FileExists(FPath)
FPath = FPath & " (" & c & ")" : c = c + 1
Wend : FPath = LP(FPath)
If Left(IPath, 1) = "\" Or Left(FPath, 1) = "\" Then _
CreateForLong IPath, FPath Else .MoveFile IPath, FPath
End If
Next
End If
Next
End With : Set FSO = Nothing
Set Rgx = Nothing : Set Strm = Nothing
MsgBox Space(16) & "Выполнено!", 4160,_
" Перемещение файлов в папки-маски "
Sub CreateForLong(Input, OutPut)
With Strm
Dim Size, All : Size = FSO.GetFile(Input).Size
.Format.Type = 1 : .Open Input, 1 : .Read All, Size : .Close
.Open OutPut, 3, True : .Write All : All = "" : .Close
End With : FSO.DeleteFile Input
End Sub
Function LP(F)
LP = F : If Len(F) > 259 And Left(F, 1) <> "\" Then LP = "\\?\" & F
End Function |