Total Commander

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

'•••••••••••••••••••••••••••••••••••••• VBS ••••••••••••••••••••••••••••••••••••••
' Распаковка выбранных архивов и/или архивов в структуре выбранных каталогов
' в одноимённые папки рядом с архивами (при наличии в них более одного элемента)
' c автоматическим переходом в случае распаковки одного архива

' Условие: необходима текущая версия утилиты 7z.exe

' Параметры:
' 1. %WL (обязательный)
' 2. <расширения архивов (в т.ч. двойные) через "|"> ("" - все поддерживаемые)
' 3. <пропустить/перезаписать существующие/переименовать извлекаемые файлы: s/a/u>
' 4. Суммируемые значения опций:
'      1 = Распаковка зашифрованных архивов.
'      2 = Удаление удачно распакованных архивов.
'      4 = Не распаковывать архивы нулевой структуры.
'      8 = Обработка всей структуры выбранных каталогов.
'     16 = Распаковка одиночных элементов без подкаталогов.

' Примеры: %WL | %WL "" a | %WL 7z|7zip|arj|bzip2|rar|tar.bz2|zip | %WL "" s 25

Option Explicit : Dim Z7
'••••••••• Путь к утилите 7z.exe •••••••••
Z7 = "%COMMANDER_PATH%\Utils\7-Zip\7z.exe"
'•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••• Автор: Flasher © •••

Dim A, C, Filt, O, Mode, List, WSS, FSO, Pass, PWTrue
Set A = WSH.Arguments : C = A.Count: If C = 0 Then WSH.Quit
If C > 1 Then Filt = LCase(A(1))
If C > 2 Then Mode = " -ao" & A(2) : If C > 3 Then O = A(3)
List = A(0): Set WSS = CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
If InStrRev(LCase(WSH.FullName), "wscript.exe") Then
  Dim Par, Pars
  For Par = 1 To C - 1
    If A(Par) <> "" Then
      Pars = Pars & " " & A(Par)
    ElseIf C - 1 > Par Then Pars = Pars & " """""
    End If
  Next : WSS.Run "cscript.exe //NoLogo """ & WSH.ScriptFullName & """ " & List & Pars,0
  If FSO.GetDrive(FSO.GetDriveName(WSH.FullName)).IsReady Then WSH.Sleep 500 : WSH.Quit
End If : Dim Reg, Cvt, ShA, Fi, Ch, Cn, It : Set Reg = New Regexp
If FSO.FileExists(FSO.GetSpecialFolder(1) & "\oleprn.dll") Then _
Set Cvt = CreateObject("OlePrn.OleCvt.1")
Set ShA = CreateObject("Shell.Application")
Reg.IgnoreCase = True : Reg.Pattern = "^(001|7z(|ip)|a|apm|arj?|bz(|ip)2|cab|cpio|ch[iqmw]" &_
"|cramfs|deb|dmg|docx?|e(sd|pub|xe|xt[234]?)|fat|gz(|ip)|hfsx?|hx[sirqw]|ihex|img|iso|jar|" &_
"li[bt]|l(zh|ma)|lha|mbr|ms(i|lz|sp)|mub|n(si|tf)s|od[st]|qcow(|2c?)|r00|rar|rpm|pkg|ppmd|" &_
"ppt|squashfs|scap|swm|t[agx]z|tar|tbz2?|u(d|efi)f|vdi|vhd|vmdk|wim|x(ar|lsx?|pi|z)|z|zipx?)$"
Dim Rgx : Set Rgx = New RegExp : Rgx.MultiLine = True : Rgx.Global = True
Dim REx : Set REx = New RegExp : REx.MultiLine = True : REx.Global = True
Rgx.Pattern = "^Path = ([^\\\r\n]+)$" : REx.Pattern = "^Size = ([1-9]\d*)?$"

With FSO.OpenTextFile(List,,,-1)
  Do : Fi = Trim(.ReadLine)
    If Fi <> "" Then If FSO.FileExists("\\?\" & Fi) Then _
    ForFile Fi, Ch, It, Cn Else If (O And 8) = 8 Then ForFolder Fi, Ch, It, Cn
  Loop Until .AtEndOfStream : .Close
End With
If Ch > 1 Then WSS.Popup "Распаковка завершена!", 1.4 , " Результат", 64
If Ch = 1 Then If FSO.FileExists(It) Or FSO.FolderExists(It) Then _
If Cn > 1 And FSO.FolderExists(It) Then It = FSO.GetParentFolderName(It) End If :_
WSS.Exec """%COMMANDER_EXE%"" /A /S /O /L=""" & Replace(It, "\\?\", "") & """"
If FSO.FileExists(List) Then FSO.DeleteFile List

Sub ForFile(Arch, T, F1, Sum)
  Dim Ext, BN, Ex, Exe, Item : Ext = LCase(FSO.GetExtensionName(Arch))
  BN = FSO.GetBaseName(Arch) : Ex  = LCase(FSO.GetExtensionName(BN))
  Ex = Len(Ex) * InStr("|" & Filt & "|", "|" & Ex & "." & Ext & "|")
  If (Filt = "" Or Ex Or InStr("|" & Filt & "|", "|" & Ext & "|")) And Reg.Test(Ext) Then
    PWTrue = 1 : If (O And 1) = 1 Then GetPass Arch, "" : If PWTrue = 0 Then Exit Sub
    Set Exe = WSS.Exec("%comspec% /c chcp 1251|""" & Z7 & """ l" &_
                       " -slt """ & Arch & """ -sccUTF-8 -p" & Pass)
    Dim All : All = Split(Exe.StdOut.ReadAll, "----------")(1)
    If (O And 1) = 0 Then If InStr(All, vbLf & "Encrypted = +" & vbCr) Then Exit Sub
    If InStr(All, vbLf & "Errors:" & vbCr) Then Exit Sub
    Dim Sz, Szs, Size : Sum = Rgx.Execute(All).Count
    For Each Sz in REx.Execute(All)
      Szs = Sz.Submatches(0) : If Len(Szs) Then Size = CDbl(Size) + Szs Else Exit For
    Next : If (O And 4) = 4 And CDbl(Size) = 0 Then Exit Sub
    If Sum Then Item = Rgx.Execute(All)(0).SubMatches(0)
    If Sum < 2 And Size Then
      With New RegExp
        .Global = True : .Pattern = "\nPath = ([^\\\r\n]+)" : Sum = 1
        Dim Col: Set Col = .Execute(All) : Item = Col.Item(0).SubMatches(0)
      End With : If Item <> Col(Col.Count - 1).SubMatches(0) Then Sum = 2
    End If
    If Sum = 0 And Ext = "zip" And Len(Arch) < 260 Then
      Dim Items : Set Items = ShA.NameSpace(Arch).Items
      Sum = Items.Count : If Sum Then Item = Items.Item(0)
      For Each I in Items : Size = CDbl(Size) + I.Size : Next
    End If
    If Sum > 0 Or FSO.GetFile(LPath(Arch)).Size Then
      Dim P, Fd, NF : P = FSO.GetParentFolderName(Arch) : Fd = P & "\" & BN
      If IsEmpty(Cvt) Then UTF8 Item Else Item = Cvt.ToUnicode(Item, 65001)
      If Sum = 1 And ((O And 16) = 16 Or BN = Item) Then NF = P Else NF = Fd
      F1 = LPath(NF & "\" & Item)
      Dim FdExist: FdExist = Not FSO.FolderExists(LPath(Fd))
      Dim F1Exist: F1Exist = Not (FSO.FileExists(F1) Or FSO.FolderExists(F1))
      WSS.Run """" & Z7 & """ x """ & Arch & """ -o""" &_
              NF & """" & Mode & " -y -p" & Pass, 0, True
      Dim Fl, FE : Fd = LPath(Fd) : T = T + 1
      Select Case True
        Case FSO.FileExists(F1)   And Sum = 1 Set Fl = FSO.GetFile(F1)   : FE = F1Exist
        Case FSO.FolderExists(F1) And Sum = 1 Set Fl = FSO.GetFolder(F1) : FE = F1Exist
        Case FSO.FolderExists(Fd) Set Fl = FSO.GetFolder(Fd) : FE = FdExist :_
        If Sum = 1 Then F1 = Fd
      End Select : SZ = Fl.Size
      If (Len(Szs) > 0 And CDbl(Size) <> SZ) Or ((O And 4) = 4 And FE And SZ = 0) Then
        If (Fl.Attributes And 1) = 1 Then Fl.Attributes = 0
        Fl.Delete : T = T - 1
      End If : If (O And 2) = 2 And CDbl(Size) = SZ Then FSO.DeleteFile LPath(Arch), 1
    End If
  End If
End Sub

Sub GetPass(Arc, Text)
  If Len(WSS.Exec("""" & Z7 & """ t """ & Arc & """ -y -p" & Pass).StdErr.Read(1)) Then
    PWTrue = 0 : Pass = InputBox(vbCr & "Архив:  """ & Arc & """" & vbCr & vbCr &_
    Text & vbCr & vbCr & "Введите пароль:", Space(30) & "Распаковка архивов", Pass)
    If Len(Pass) Then Text = Space(40) & "Пароль неверен!" : GetPass Arc, Text
  Else PWTrue = 1 End If
End Sub

Sub UTF8(Nm): Dim F
  While Len(Nm) > 0
    If Asc(Left(Nm,1)) >= 128 Then
      If Asc(Left(Nm,1)) < 224 Then F = F & ChrW(S(Nm,2,64) + S(Nm,1,32)*64):_
        Nm = Right(Nm, Len(Nm)-2) Else F = F & ChrW(S(Nm,3,64) + (S(Nm,2,32)+_
        S(Nm, 1, 16)*64)*64) : Nm = Right(Nm, Len(Nm) - 3)
    Else F = F & Left(Nm, 1) : Nm = Right(Nm, Len(Nm) - 1) End If
  Wend : Nm = F
End Sub : Function S(Name, b, m) S = Asc(Mid(Name, b, 1)) Mod m End Function

Sub ForFolder(Fold, T, F1, Cnt)
  Dim N : Set Fold = FSO.GetFolder(LPath(Fold))
  For Each N In Fold.SubFolders : ForFolder N.Path, Ch, It, Cnt : Next
  For Each N In Fold.Files      : ForFile   N.Path, Ch, It, Cnt : Next
End Sub

Function LPath(Obj)
  LPath = Obj : If Len(Obj) > 259 And Left(Obj, 1) <> "\" Then LPath = "\\?\" & Obj
End Function

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

%WL "" 1 s 25