Total Commander

Код: Выделить всё

'=================== 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